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

psblas3-integer8:

Browse Source 
base/comm/psb_cgather.f90
 base/comm/psb_chalo.f90
 base/comm/psb_covrl.f90
 base/comm/psb_cscatter.F90
 base/comm/psb_cspgather.F90
 base/comm/psb_dgather.f90
 base/comm/psb_dhalo.f90
 base/comm/psb_dovrl.f90
 base/comm/psb_dscatter.F90
 base/comm/psb_dspgather.F90
 base/comm/psb_igather.f90
 base/comm/psb_ihalo.f90
 base/comm/psb_iovrl.f90
 base/comm/psb_iscatter.F90
 base/comm/psb_sgather.f90
 base/comm/psb_shalo.f90
 base/comm/psb_sovrl.f90
 base/comm/psb_sscatter.F90
 base/comm/psb_sspgather.F90
 base/comm/psb_zgather.f90
 base/comm/psb_zhalo.f90
 base/comm/psb_zovrl.f90
 base/comm/psb_zscatter.F90
 base/comm/psb_zspgather.F90
 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

Comm stuff.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 9c153be7ff
commit 72d52a981d
34 changed files with 1001 additions and 862 deletions
Show Stats Download Patch File Download Diff File

42
base/comm/psb_cgather.f90
Unescape Escape View File

@ -35,9 +35,9 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one. ! This subroutine gathers pieces of a distributed dense matrix into a local one.
! !
! Arguments: ! Arguments:
! globx - cplx,dimension(:,:). The local matrix into which gather ! globx - complex,dimension(:,:). The local matrix into which gather
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:,:). The local piece of the distributed ! locx - complex,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
@ -57,8 +57,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -82,8 +82,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -115,9 +115,9 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -207,9 +207,9 @@ end subroutine psb_cgatherm
! This subroutine gathers pieces of a distributed dense vector into a local one. ! This subroutine gathers pieces of a distributed dense vector into a local one.
! !
! Arguments: ! Arguments:
! globx - cplx,dimension(:). The local vector into which gather ! globx - complex,dimension(:). The local vector into which gather
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:). The local piece of the distributed ! locx - complex,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
@ -230,8 +230,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -255,8 +255,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -279,9 +279,9 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -341,8 +341,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
complex(psb_spk_), allocatable :: llocx(:) complex(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -366,8 +366,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -390,7 +390,7 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then

27
base/comm/psb_chalo.f90
Unescape Escape View File

@ -67,9 +67,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_ & err, liwork,data_, ldx
complex(psb_spk_),pointer :: iwork(:), xp(:,:) complex(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,9 +129,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else else
data_ = psb_comm_halo_ data_ = psb_comm_halo_
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -148,9 +148,9 @@ subroutine psb_chalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= cone) then
do i=0, k-1 do i=0, k-1
call cscal(nrow,alpha,x(:,jjx+i),1) call cscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1)
end do end do
end if end if
end if end if
@ -289,7 +289,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, & integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
@ -333,9 +334,9 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
else else
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -352,8 +353,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= cone) then
call cscal(nrow,alpha,x,ione) call cscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if end if
end if end if
@ -486,7 +487,7 @@ subroutine psb_chalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

22
base/comm/psb_covrl.f90
Unescape Escape View File

@ -76,9 +76,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
complex(psb_spk_),pointer :: iwork(:), xp(:,:) complex(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -135,9 +135,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -177,7 +177,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
end if end if
! exchange overlap elements ! exchange overlap elements
if(do_swap) then if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,cone,xp,& call psi_swapdata(mode_,k,cone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
@ -278,7 +278,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -321,9 +321,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -403,7 +403,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork,ldx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -453,7 +453,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

31
base/comm/psb_cscatter.F90
Unescape Escape View File

@ -62,10 +62,10 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, c, pos
complex(psb_spk_),allocatable :: scatterv(:) complex(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -89,8 +89,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -128,8 +128,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -295,10 +295,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
& rootrank, pos, ilx, jlx
complex(psb_spk_), allocatable :: scatterv(:) complex(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -325,8 +324,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -349,9 +348,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

21
base/comm/psb_cspgather.F90
Unescape Escape View File

@ -18,10 +18,12 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg integer(psb_mpik_) :: ictxt,np,me, icomm, minfo
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -53,8 +55,8 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
allocate(nzbr(np), idisp(np),stat=info) allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& ierr(1) = 2*np
& a_err='integer') call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999 goto 9999
end if end if
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
@ -70,15 +72,16 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
ndx = nzbr(me+1) ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,& call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& mpi_complex,icomm,info) & mpi_complex,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,& & glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& glob_coo%ja,nzbr,idisp,& & glob_coo%ja,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if

56
base/comm/psb_dgather.f90
Unescape Escape View File

@ -40,11 +40,10 @@
! locx - real,dimension(:,:). The local piece of the distributed ! locx - real,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! Default: -1.
! !
subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dgatherm use psb_base_mod, psb_protect_name => psb_dgatherm
@ -58,9 +57,10 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dgatherm' name='psb_dgatherm'
@ -82,8 +82,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -115,9 +115,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -131,7 +131,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if end if
globx(:,:)=0.d0 globx(:,:)=dzero
do j=1,k do j=1,k
do i=1,desc_a%get_local_rows() do i=1,desc_a%get_local_rows()
@ -207,15 +207,16 @@ end subroutine psb_dgatherm
! This subroutine gathers pieces of a distributed dense vector into a local one. ! This subroutine gathers pieces of a distributed dense vector into a local one.
! !
! Arguments: ! Arguments:
! globx - real,dimension(:). The local vector into which gather the ! globx - real,dimension(:). The local vector into which gather
! distributed pieces. ! the distributed pieces.
! locx - real,dimension(:). The local piece of the ditributed ! locx - real,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Error code.
! root - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! default: -1
! !
subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dgatherv use psb_base_mod, psb_protect_name => psb_dgatherv
@ -229,8 +230,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -254,8 +255,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -278,9 +279,9 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -294,7 +295,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if end if
globx(:)=0.d0 globx(:)=dzero
do i=1,desc_a%get_local_rows() do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info) call psb_loc_to_glob(i,idx,desc_a,info)
@ -340,13 +341,13 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
real(psb_dpk_), allocatable :: llocx(:) real(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dgatherv' name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -365,8 +366,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -389,7 +390,7 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -408,7 +409,6 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
globx(:) = dzero globx(:) = dzero
llocx = locx%get_vect() llocx = locx%get_vect()
do i=1,desc_a%get_local_rows() do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info) call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = llocx(i) globx(idx) = llocx(i)

27
base/comm/psb_dhalo.f90
Unescape Escape View File

@ -67,9 +67,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_ & err, liwork,data_, ldx
real(psb_dpk_),pointer :: iwork(:), xp(:,:) real(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,9 +129,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else else
data_ = psb_comm_halo_ data_ = psb_comm_halo_
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -148,9 +148,9 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= done) then
do i=0, k-1 do i=0, k-1
call dscal(nrow,alpha,x(:,jjx+i),1) call dscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1)
end do end do
end if end if
end if end if
@ -289,7 +289,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, & integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
@ -333,9 +334,9 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
else else
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -352,8 +353,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= done) then
call dscal(nrow,alpha,x,ione) call dscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if end if
end if end if
@ -486,7 +487,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

22
base/comm/psb_dovrl.f90
Unescape Escape View File

@ -76,9 +76,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
real(psb_dpk_),pointer :: iwork(:), xp(:,:) real(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -135,9 +135,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -177,7 +177,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if end if
! exchange overlap elements ! exchange overlap elements
if(do_swap) then if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,done,xp,& call psi_swapdata(mode_,k,done,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
@ -278,7 +278,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -321,9 +321,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -403,7 +403,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork,ldx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -453,7 +453,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

42
base/comm/psb_dscatter.F90
Unescape Escape View File

@ -37,12 +37,12 @@
! !
! Arguments: ! Arguments:
! globx - real,dimension(:,:). The global matrix to scatter. ! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the ditributed matrix. ! locx - real,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all ! iroot - integer(optional). The process that owns the global matrix.
! the processes have a copy. Default -1. ! If -1 all the processes have a copy.
! ! Default -1
subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dscatterm use psb_base_mod, psb_protect_name => psb_dscatterm
@ -62,10 +62,10 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, c, pos
real(psb_dpk_),allocatable :: scatterv(:) real(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -89,8 +89,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -128,8 +128,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -273,13 +273,12 @@ end subroutine psb_dscatterm
! globx - real,dimension(:). The global vector to scatter. ! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector. ! locx - real,dimension(:). The local piece of the ditributed vector.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dscatterv use psb_base_mod, psb_protect_name => psb_dscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -296,10 +295,9 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
& rootrank, pos, ilx, jlx
real(psb_dpk_), allocatable :: scatterv(:) real(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -326,8 +324,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -350,9 +348,9 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

23
base/comm/psb_dspgather.F90
Unescape Escape View File

@ -18,10 +18,12 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg integer(psb_mpik_) :: ictxt,np,me, icomm, minfo
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -53,8 +55,8 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
allocate(nzbr(np), idisp(np),stat=info) allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& ierr(1) = 2*np
& a_err='integer') call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999 goto 9999
end if end if
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
@ -68,17 +70,18 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
ndx = nzbr(me+1) ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,mpi_double_precision,& call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& mpi_double_precision,icomm,info) & mpi_complex,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,& & glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& glob_coo%ja,nzbr,idisp,& & glob_coo%ja,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if

24
base/comm/psb_igather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -82,8 +82,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -115,9 +115,9 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -229,8 +229,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -254,8 +254,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -278,9 +278,9 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

12
base/comm/psb_ihalo.f90
Unescape Escape View File

@ -70,7 +70,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, k, maxk, liwork,& & err_act, m, n, iix, jjx, ix, ijx, nrow, k, maxk, liwork,&
& imode, err,data_ & imode, err,data_, ldx
integer(psb_ipk_), pointer :: xp(:,:), iwork(:) integer(psb_ipk_), pointer :: xp(:,:), iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -133,8 +133,9 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -186,7 +187,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
end if end if
end if end if
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
! exchange halo elements ! exchange halo elements
if(tran_ == 'N') then if(tran_ == 'N') then
call psi_swapdata(imode,k,izero,xp,& call psi_swapdata(imode,k,izero,xp,&
@ -294,7 +295,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork, data_ & err, liwork, data_,ldx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -340,8 +341,9 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

11
base/comm/psb_iovrl.f90
Unescape Escape View File

@ -77,7 +77,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
integer(psb_ipk_), pointer :: iwork(:), xp(:,:) integer(psb_ipk_), pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -134,9 +134,9 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -278,7 +278,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -322,8 +322,9 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

31
base/comm/psb_iscatter.F90
Unescape Escape View File

@ -60,10 +60,10 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: iroot
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, c, pos
integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -87,8 +87,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)= root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -126,8 +126,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -293,10 +293,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
& rootrank, pos, ilx, jlx
integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -323,8 +322,8 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2) = root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -347,9 +346,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

52
base/comm/psb_sgather.f90
Unescape Escape View File

@ -40,11 +40,10 @@
! locx - real,dimension(:,:). The local piece of the distributed ! locx - real,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! Default: -1.
! !
subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sgatherm use psb_base_mod, psb_protect_name => psb_sgatherm
@ -58,9 +57,10 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_sgatherm' name='psb_sgatherm'
@ -82,8 +82,8 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -115,9 +115,9 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -207,15 +207,16 @@ end subroutine psb_sgatherm
! This subroutine gathers pieces of a distributed dense vector into a local one. ! This subroutine gathers pieces of a distributed dense vector into a local one.
! !
! Arguments: ! Arguments:
! globx - real,dimension(:). The local vector into which gather the ! globx - real,dimension(:). The local vector into which gather
! distributed pieces. ! the distributed pieces.
! locx - real,dimension(:). The local piece of the ditributed ! locx - real,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Error code.
! root - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! default: -1
! !
subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sgatherv use psb_base_mod, psb_protect_name => psb_sgatherv
@ -229,8 +230,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -254,8 +255,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -278,9 +279,9 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -340,13 +341,13 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
real(psb_spk_), allocatable :: llocx(:) real(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dgatherv' name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -365,8 +366,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -389,7 +390,7 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -408,7 +409,6 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
globx(:) = szero globx(:) = szero
llocx = locx%get_vect() llocx = locx%get_vect()
do i=1,desc_a%get_local_rows() do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info) call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = llocx(i) globx(idx) = llocx(i)

27
base/comm/psb_shalo.f90
Unescape Escape View File

@ -67,9 +67,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_ & err, liwork,data_, ldx
real(psb_spk_),pointer :: iwork(:), xp(:,:) real(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,9 +129,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else else
data_ = psb_comm_halo_ data_ = psb_comm_halo_
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -148,9 +148,9 @@ subroutine psb_shalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= sone) then
do i=0, k-1 do i=0, k-1
call sscal(nrow,alpha,x(:,jjx+i),1) call sscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1)
end do end do
end if end if
end if end if
@ -289,7 +289,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, & integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
@ -333,9 +334,9 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
else else
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -352,8 +353,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= sone) then
call sscal(nrow,alpha,x,ione) call sscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if end if
end if end if
@ -486,7 +487,7 @@ subroutine psb_shalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

22
base/comm/psb_sovrl.f90
Unescape Escape View File

@ -76,9 +76,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
real(psb_spk_),pointer :: iwork(:), xp(:,:) real(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -135,9 +135,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -177,7 +177,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if end if
! exchange overlap elements ! exchange overlap elements
if(do_swap) then if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,sone,xp,& call psi_swapdata(mode_,k,sone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
@ -278,7 +278,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -321,9 +321,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -403,7 +403,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork,ldx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -453,7 +453,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

43
base/comm/psb_sscatter.F90
Unescape Escape View File

@ -37,15 +37,15 @@
! !
! Arguments: ! Arguments:
! globx - real,dimension(:,:). The global matrix to scatter. ! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the ditributed matrix. ! locx - real,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all ! iroot - integer(optional). The process that owns the global matrix.
! the processes have a copy. Default -1. ! If -1 all the processes have a copy.
! ! Default -1
subroutine psb_sscatterm(globx, locx, desc_a, info, iroot) subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sscatterm
use psb_base_mod, psb_protect_name => psb_sscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -62,10 +62,10 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, c, pos
real(psb_spk_),allocatable :: scatterv(:) real(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -89,8 +89,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -128,8 +128,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -273,7 +273,7 @@ end subroutine psb_sscatterm
! globx - real,dimension(:). The global vector to scatter. ! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector. ! locx - real,dimension(:). The local piece of the ditributed vector.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
@ -295,10 +295,9 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
& rootrank, pos, ilx, jlx
real(psb_spk_), allocatable :: scatterv(:) real(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -325,8 +324,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -349,9 +348,9 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

23
base/comm/psb_sspgather.F90
Unescape Escape View File

@ -18,10 +18,12 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg integer(psb_mpik_) :: ictxt,np,me, icomm, minfo
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -53,8 +55,8 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
allocate(nzbr(np), idisp(np),stat=info) allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& ierr(1) = 2*np
& a_err='integer') call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999 goto 9999
end if end if
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
@ -68,17 +70,18 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
ndx = nzbr(me+1) ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,mpi_real,& call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& mpi_real,icomm,info) & mpi_complex,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,& & glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& glob_coo%ja,nzbr,idisp,& & glob_coo%ja,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if

42
base/comm/psb_zgather.f90
Unescape Escape View File

@ -35,9 +35,9 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one. ! This subroutine gathers pieces of a distributed dense matrix into a local one.
! !
! Arguments: ! Arguments:
! globx - cplx,dimension(:,:). The local matrix into which gather ! globx - complex,dimension(:,:). The local matrix into which gather
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:,:). The local piece of the distributed ! locx - complex,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
@ -57,8 +57,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -82,8 +82,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -115,9 +115,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -207,9 +207,9 @@ end subroutine psb_zgatherm
! This subroutine gathers pieces of a distributed dense vector into a local one. ! This subroutine gathers pieces of a distributed dense vector into a local one.
! !
! Arguments: ! Arguments:
! globx - cplx,dimension(:). The local vector into which gather ! globx - complex,dimension(:). The local vector into which gather
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:). The local piece of the distributed ! locx - complex,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
@ -230,8 +230,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -255,8 +255,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -279,9 +279,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -341,8 +341,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, n, root, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
complex(psb_dpk_), allocatable :: llocx(:) complex(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -366,8 +366,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -390,7 +390,7 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then

27
base/comm/psb_zhalo.f90
Unescape Escape View File

@ -67,9 +67,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_ & err, liwork,data_, ldx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:) complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,9 +129,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else else
data_ = psb_comm_halo_ data_ = psb_comm_halo_
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -148,9 +148,9 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= zone) then
do i=0, k-1 do i=0, k-1
call zscal(nrow,alpha,x(:,jjx+i),1) call zscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1)
end do end do
end if end if
end if end if
@ -289,7 +289,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, err_act, & integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
@ -333,9 +334,9 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
else else
imode = IOR(psb_swap_send_,psb_swap_recv_) imode = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -352,8 +353,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
if(err /= 0) goto 9999 if(err /= 0) goto 9999
if(present(alpha)) then if(present(alpha)) then
if(alpha /= 1.d0) then if(alpha /= zone) then
call zscal(nrow,alpha,x,ione) call zscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if end if
end if end if
@ -486,7 +487,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

22
base/comm/psb_zovrl.f90
Unescape Escape View File

@ -76,9 +76,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:) complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -135,9 +135,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -177,7 +177,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if end if
! exchange overlap elements ! exchange overlap elements
if(do_swap) then if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,zone,xp,& call psi_swapdata(mode_,k,zone,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
@ -278,7 +278,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork, ldx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -321,9 +321,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -403,7 +403,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork & mode_, err, liwork,ldx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -453,7 +453,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,1,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

32
base/comm/psb_zscatter.F90
Unescape Escape View File

@ -44,6 +44,7 @@
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! Default -1
subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_zscatterm use psb_base_mod, psb_protect_name => psb_zscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -61,10 +62,10 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,& integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, c, pos
complex(psb_dpk_),allocatable :: scatterv(:) complex(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -88,8 +89,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -127,8 +128,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -294,10 +295,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
& rootrank, pos, ilx, jlx
complex(psb_dpk_), allocatable :: scatterv(:) complex(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -324,8 +324,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/) ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
@ -348,9 +348,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info) call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'

23
base/comm/psb_zspgather.F90
Unescape Escape View File

@ -18,10 +18,12 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_ipk_) :: ictxt,np,me, err_act, icomm, dupl_, nrg, ncg, nzg integer(psb_mpik_) :: ictxt,np,me, icomm, minfo
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -53,8 +55,8 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
allocate(nzbr(np), idisp(np),stat=info) allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),& ierr(1) = 2*np
& a_err='integer') call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999 goto 9999
end if end if
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
@ -68,17 +70,18 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
ndx = nzbr(me+1) ndx = nzbr(me+1)
call mpi_allgatherv(loc_coo%val,ndx,mpi_double_complex,& call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& mpi_double_complex,icomm,info) & mpi_complex,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,& & glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,& if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& glob_coo%ja,nzbr,idisp,& & glob_coo%ja,nzbr,idisp,&
& psb_mpi_integer,icomm,info) & psb_mpi_integer,icomm,minfo)
if (info /= psb_success_) then if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if

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

@ -156,7 +156,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_cswapdatam end subroutine psi_cswapdatam
subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidxm use psi_mod, psb_protect_name => psi_cswapidxm
use psb_error_mod use psb_error_mod
@ -170,20 +170,21 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:,:), beta complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -197,7 +198,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -303,9 +305,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_complex,rcvbuf,rvsz,& & mpi_complex,rcvbuf,rvsz,&
& brvidx,mpi_complex,icomm,iret) & brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -371,7 +373,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
@ -395,9 +397,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -420,9 +422,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -653,7 +655,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_cswapdatav end subroutine psi_cswapdatav
subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidxv use psi_mod, psb_protect_name => psi_cswapidxv
use psb_error_mod use psb_error_mod
@ -667,21 +669,21 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -695,7 +697,8 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -801,9 +804,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_complex,rcvbuf,rvsz,& & mpi_complex,rcvbuf,rvsz,&
& brvidx,mpi_complex,icomm,iret) & brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -866,7 +869,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -890,9 +893,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -913,9 +916,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1087,7 +1090,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_cswapdata_vect end subroutine psi_cswapdata_vect
subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_cswapidx_vect use psi_mod, psb_protect_name => psi_cswapidx_vect
use psb_error_mod use psb_error_mod
@ -1102,7 +1105,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
@ -1110,14 +1113,14 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1131,7 +1134,8 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -1237,9 +1241,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_complex,rcvbuf,rvsz,& & mpi_complex,rcvbuf,rvsz,&
& brvidx,mpi_complex,icomm,iret) & brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1302,7 +1306,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1326,9 +1330,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1349,9 +1353,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -111,7 +111,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -161,7 +161,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_cswaptranm end subroutine psi_cswaptranm
subroutine psi_ctranidxm(ictxt,icomm,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 psi_mod, psb_protect_name => psi_ctranidxm
use psb_error_mod use psb_error_mod
@ -175,20 +175,27 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:,:), beta complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ 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_
!!$ 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -202,6 +209,8 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -314,9 +323,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_complex,& & mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -379,7 +388,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -402,9 +411,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -426,9 +435,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -606,7 +615,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -657,7 +666,7 @@ end subroutine psi_cswaptranv
subroutine psi_ctranidxv(ictxt,icomm,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 psi_mod, psb_protect_name => psi_ctranidxv
use psb_error_mod use psb_error_mod
@ -671,20 +680,27 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:) complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -698,6 +714,8 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -809,9 +827,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_complex,& & mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -874,7 +892,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -897,9 +915,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -920,9 +938,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1049,7 +1067,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -1100,7 +1118,7 @@ end subroutine psi_cswaptran_vect
subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,& subroutine psi_ctranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidx_vect use psi_mod, psb_protect_name => psi_ctranidx_vect
@ -1116,7 +1134,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta complex(psb_spk_) :: beta
@ -1124,13 +1142,14 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1144,6 +1163,8 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -1255,9 +1276,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_complex,& & mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1320,7 +1341,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1343,9 +1364,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1366,9 +1387,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -156,7 +156,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_dswapdatam end subroutine psi_dswapdatam
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dswapidxm use psi_mod, psb_protect_name => psi_dswapidxm
use psb_error_mod use psb_error_mod
@ -170,20 +170,21 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -197,7 +198,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -303,9 +305,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_double_precision,rcvbuf,rvsz,& & mpi_double_precision,rcvbuf,rvsz,&
& brvidx,mpi_double_precision,icomm,iret) & brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -371,7 +373,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
@ -395,9 +397,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -420,9 +422,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -653,7 +655,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_dswapdatav end subroutine psi_dswapdatav
subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dswapidxv use psi_mod, psb_protect_name => psi_dswapidxv
use psb_error_mod use psb_error_mod
@ -667,21 +669,21 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -695,7 +697,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -801,9 +804,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_precision,rcvbuf,rvsz,& & mpi_double_precision,rcvbuf,rvsz,&
& brvidx,mpi_double_precision,icomm,iret) & brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -866,7 +869,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -890,9 +893,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -913,9 +916,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1087,7 +1090,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_dswapdata_vect end subroutine psi_dswapdata_vect
subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dswapidx_vect use psi_mod, psb_protect_name => psi_dswapidx_vect
use psb_error_mod use psb_error_mod
@ -1102,7 +1105,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
@ -1110,14 +1113,14 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1131,7 +1134,8 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -1237,9 +1241,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_double_precision,rcvbuf,rvsz,& & mpi_double_precision,rcvbuf,rvsz,&
& brvidx,mpi_double_precision,icomm,iret) & brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1302,7 +1306,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1326,9 +1330,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1349,9 +1353,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -111,7 +111,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -161,7 +161,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_dswaptranm end subroutine psi_dswaptranm
subroutine psi_dtranidxm(ictxt,icomm,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 psi_mod, psb_protect_name => psi_dtranidxm
use psb_error_mod use psb_error_mod
@ -175,20 +175,27 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ 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_
!!$ 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -202,6 +209,8 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -314,9 +323,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_double_precision,& & mpi_double_precision,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -379,7 +388,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -402,9 +411,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -426,9 +435,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -606,7 +615,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -657,7 +666,7 @@ end subroutine psi_dswaptranv
subroutine psi_dtranidxv(ictxt,icomm,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 psi_mod, psb_protect_name => psi_dtranidxv
use psb_error_mod use psb_error_mod
@ -671,20 +680,27 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:) real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -698,6 +714,8 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -809,9 +827,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_precision,& & mpi_double_precision,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -874,7 +892,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -897,9 +915,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -920,9 +938,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1049,7 +1067,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -1100,7 +1118,7 @@ end subroutine psi_dswaptran_vect
subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,& subroutine psi_dtranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidx_vect use psi_mod, psb_protect_name => psi_dtranidx_vect
@ -1116,7 +1134,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta real(psb_dpk_) :: beta
@ -1124,13 +1142,14 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1144,6 +1163,8 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -1255,9 +1276,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_double_precision,& & mpi_double_precision,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1320,7 +1341,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1343,9 +1364,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1366,9 +1387,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -156,7 +156,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswapdatam end subroutine psi_iswapdatam
subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidxm use psi_mod, psb_protect_name => psi_iswapidxm
use psb_error_mod use psb_error_mod
@ -170,20 +170,21 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -197,7 +198,8 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -303,9 +305,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& psb_mpi_integer,rcvbuf,rvsz,& & psb_mpi_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_integer,icomm,iret) & brvidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -371,7 +373,7 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
@ -395,9 +397,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -420,9 +422,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -653,7 +655,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_iswapdatav end subroutine psi_iswapdatav
subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidxv use psi_mod, psb_protect_name => psi_iswapidxv
use psb_error_mod use psb_error_mod
@ -667,21 +669,21 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:), beta integer(psb_ipk_) :: y(:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -695,7 +697,8 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -801,9 +804,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& psb_mpi_integer,rcvbuf,rvsz,& & psb_mpi_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_integer,icomm,iret) & brvidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -866,7 +869,7 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -890,9 +893,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -913,9 +916,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1087,7 +1090,7 @@ end subroutine psi_iswapidxv
!!$end subroutine psi_iswapdata_vect !!$end subroutine psi_iswapdata_vect
!!$ !!$
!!$ !!$
!!$subroutine psi_iswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) !!$subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
!!$ !!$
!!$ use psi_mod, psb_protect_name => psi_iswapidx_vect !!$ use psi_mod, psb_protect_name => psi_iswapidx_vect
!!$ use psb_error_mod !!$ use psb_error_mod
@ -1102,7 +1105,7 @@ end subroutine psi_iswapidxv
!!$ include 'mpif.h' !!$ include 'mpif.h'
!!$#endif !!$#endif
!!$ !!$
!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag !!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y !!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta !!$ integer(psb_ipk_) :: beta
@ -1110,14 +1113,14 @@ end subroutine psi_iswapidxv
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv !!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$ !!$
!!$ ! locals !!$ ! locals
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& !!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& !!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ & iret, err_act, i, totsnd_, totrcv_,& !!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & idx_pt, snd_pt, rcv_pt, n, pnti, data_
!!$
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd !!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: int_err(5) !!$ 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,& !!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
!!$ & albf,do_send,do_recv !!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false. !!$ logical, parameter :: usersend=.false.
@ -1131,7 +1134,8 @@ end subroutine psi_iswapidxv
!!$ info=psb_success_ !!$ info=psb_success_
!!$ name='psi_swap_datav' !!$ name='psi_swap_datav'
!!$ call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$ !!$ ictxt = iictxt
!!$ icomm = iicomm
!!$ call psb_info(ictxt,me,np) !!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then !!$ if (np == -1) then
!!$ info=psb_err_context_error_ !!$ info=psb_err_context_error_
@ -1237,9 +1241,9 @@ end subroutine psi_iswapidxv
!!$ & psb_mpi_integer,rcvbuf,rvsz,& !!$ & psb_mpi_integer,rcvbuf,rvsz,&
!!$ & brvidx,psb_mpi_integer,icomm,iret) !!$ & brvidx,psb_mpi_integer,icomm,iret)
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ !!$
@ -1302,7 +1306,7 @@ end subroutine psi_iswapidxv
!!$ !!$
!!$ !!$
!!$ ! Then I post all the blocking sends !!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,info) !!$ if (usersend) call mpi_barrier(icomm,iret)
!!$ !!$
!!$ pnti = 1 !!$ pnti = 1
!!$ snd_pt = 1 !!$ snd_pt = 1
@ -1326,9 +1330,9 @@ end subroutine psi_iswapidxv
!!$ end if !!$ end if
!!$ !!$
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ end if !!$ end if
@ -1349,9 +1353,9 @@ end subroutine psi_iswapidxv
!!$ if ((proc_to_comm /= me).and.(nerv>0)) then !!$ if ((proc_to_comm /= me).and.(nerv>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret) !!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ else if (proc_to_comm == me) then !!$ else if (proc_to_comm == me) then
@ -1446,4 +1450,4 @@ end subroutine psi_iswapidxv
!!$ end if !!$ end if
!!$ return !!$ return
!!$end subroutine psi_iswapidx_vect !!$end subroutine psi_iswapidx_vect
!!$

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

@ -111,7 +111,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -161,7 +161,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswaptranm end subroutine psi_iswaptranm
subroutine psi_itranidxm(ictxt,icomm,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 psi_mod, psb_protect_name => psi_itranidxm
use psb_error_mod use psb_error_mod
@ -175,20 +175,27 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:), beta integer(psb_ipk_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ 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_
!!$ 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -202,6 +209,8 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -314,9 +323,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& psb_mpi_integer,& & psb_mpi_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -379,7 +388,7 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -402,9 +411,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -426,9 +435,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -606,7 +615,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -657,7 +666,7 @@ end subroutine psi_iswaptranv
subroutine psi_itranidxv(ictxt,icomm,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 psi_mod, psb_protect_name => psi_itranidxv
use psb_error_mod use psb_error_mod
@ -671,20 +680,27 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:), beta integer(psb_ipk_) :: y(:), beta
integer(psb_ipk_), target :: work(:) integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -698,6 +714,8 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -809,9 +827,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& psb_mpi_integer,& & psb_mpi_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -874,7 +892,7 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -897,9 +915,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -920,9 +938,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1049,7 +1067,7 @@ end subroutine psi_itranidxv
!!$ ! locals !!$ ! locals
!!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ !!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
!!$ integer(psb_ipk_), pointer :: d_idx(:) !!$ integer(psb_ipk_), pointer :: d_idx(:)
!!$ integer(psb_ipk_) :: int_err(5) !!$ integer(psb_ipk_) :: ierr(5)
!!$ character(len=20) :: name !!$ character(len=20) :: name
!!$ !!$
!!$ info=psb_success_ !!$ info=psb_success_
@ -1100,7 +1118,7 @@ end subroutine psi_itranidxv
!!$ !!$
!!$ !!$
!!$ !!$
!!$subroutine psi_itranidx_vect(ictxt,icomm,flag,beta,y,idx,& !!$subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!!$ & totxch,totsnd,totrcv,work,info) !!$ & totxch,totsnd,totrcv,work,info)
!!$ !!$
!!$ use psi_mod, psb_protect_name => psi_itranidx_vect !!$ use psi_mod, psb_protect_name => psi_itranidx_vect
@ -1116,7 +1134,7 @@ end subroutine psi_itranidxv
!!$ include 'mpif.h' !!$ include 'mpif.h'
!!$#endif !!$#endif
!!$ !!$
!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag !!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y !!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta !!$ integer(psb_ipk_) :: beta
@ -1124,13 +1142,14 @@ end subroutine psi_itranidxv
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv !!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$ !!$
!!$ ! locals !!$ ! locals
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,& !!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),& !!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ & iret, err_act, i, idx_pt, totsnd_, totrcv_,& !!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & snd_pt, rcv_pt, pnti, data_, n
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd !!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: int_err(5) !!$ 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,& !!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
!!$ & albf,do_send,do_recv !!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false. !!$ logical, parameter :: usersend=.false.
@ -1144,6 +1163,8 @@ end subroutine psi_itranidxv
!!$ info=psb_success_ !!$ info=psb_success_
!!$ name='psi_swap_tran' !!$ name='psi_swap_tran'
!!$ call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$ ictxt = iictxt
!!$ icomm = iicomm
!!$ !!$
!!$ call psb_info(ictxt,me,np) !!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then !!$ if (np == -1) then
@ -1255,9 +1276,9 @@ end subroutine psi_itranidxv
!!$ & psb_mpi_integer,& !!$ & psb_mpi_integer,&
!!$ & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret) !!$ & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ !!$
@ -1320,7 +1341,7 @@ end subroutine psi_itranidxv
!!$ !!$
!!$ !!$
!!$ ! Then I post all the blocking sends !!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,info) !!$ if (usersend) call mpi_barrier(icomm,iret)
!!$ !!$
!!$ pnti = 1 !!$ pnti = 1
!!$ snd_pt = 1 !!$ snd_pt = 1
@ -1343,9 +1364,9 @@ end subroutine psi_itranidxv
!!$ end if !!$ end if
!!$ !!$
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ end if !!$ end if
@ -1366,9 +1387,9 @@ end subroutine psi_itranidxv
!!$ if ((proc_to_comm /= me).and.(nesd>0)) then !!$ if ((proc_to_comm /= me).and.(nesd>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret) !!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then !!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret !!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_ !!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err) !!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999 !!$ goto 9999
!!$ end if !!$ end if
!!$ else if (proc_to_comm == me) then !!$ else if (proc_to_comm == me) then

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

@ -156,7 +156,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_sswapdatam end subroutine psi_sswapdatam
subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidxm use psi_mod, psb_protect_name => psi_sswapidxm
use psb_error_mod use psb_error_mod
@ -170,20 +170,21 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:,:), beta real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -197,7 +198,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -303,9 +305,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_real,rcvbuf,rvsz,& & mpi_real,rcvbuf,rvsz,&
& brvidx,mpi_real,icomm,iret) & brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -371,7 +373,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
@ -395,9 +397,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -420,9 +422,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -653,7 +655,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_sswapdatav end subroutine psi_sswapdatav
subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidxv use psi_mod, psb_protect_name => psi_sswapidxv
use psb_error_mod use psb_error_mod
@ -667,21 +669,21 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -695,7 +697,8 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -801,9 +804,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_real,rcvbuf,rvsz,& & mpi_real,rcvbuf,rvsz,&
& brvidx,mpi_real,icomm,iret) & brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -866,7 +869,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -890,9 +893,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -913,9 +916,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1087,7 +1090,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_sswapdata_vect end subroutine psi_sswapdata_vect
subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_sswapidx_vect use psi_mod, psb_protect_name => psi_sswapidx_vect
use psb_error_mod use psb_error_mod
@ -1102,7 +1105,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta
@ -1110,14 +1113,14 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1131,7 +1134,8 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -1237,9 +1241,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_real,rcvbuf,rvsz,& & mpi_real,rcvbuf,rvsz,&
& brvidx,mpi_real,icomm,iret) & brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1302,7 +1306,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1326,9 +1330,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1349,9 +1353,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -111,7 +111,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -161,7 +161,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_sswaptranm end subroutine psi_sswaptranm
subroutine psi_stranidxm(ictxt,icomm,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 psi_mod, psb_protect_name => psi_stranidxm
use psb_error_mod use psb_error_mod
@ -175,20 +175,27 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:,:), beta real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ 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_
!!$ 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -202,6 +209,8 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -314,9 +323,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_real,& & mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -379,7 +388,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -402,9 +411,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -426,9 +435,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -606,7 +615,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -657,7 +666,7 @@ end subroutine psi_sswaptranv
subroutine psi_stranidxv(ictxt,icomm,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 psi_mod, psb_protect_name => psi_stranidxv
use psb_error_mod use psb_error_mod
@ -671,20 +680,27 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:) real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -698,6 +714,8 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -809,9 +827,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_real,& & mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -874,7 +892,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -897,9 +915,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -920,9 +938,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1049,7 +1067,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -1100,7 +1118,7 @@ end subroutine psi_sswaptran_vect
subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,& subroutine psi_stranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidx_vect use psi_mod, psb_protect_name => psi_stranidx_vect
@ -1116,7 +1134,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta real(psb_spk_) :: beta
@ -1124,13 +1142,14 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1144,6 +1163,8 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -1255,9 +1276,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_real,& & mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1320,7 +1341,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1343,9 +1364,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1366,9 +1387,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -156,7 +156,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_zswapdatam end subroutine psi_zswapdatam
subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidxm use psi_mod, psb_protect_name => psi_zswapidxm
use psb_error_mod use psb_error_mod
@ -170,20 +170,21 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -197,7 +198,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_data' name='psi_swap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -303,9 +305,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_double_complex,rcvbuf,rvsz,& & mpi_double_complex,rcvbuf,rvsz,&
& brvidx,mpi_double_complex,icomm,iret) & brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -371,7 +373,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
@ -395,9 +397,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -420,9 +422,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -653,7 +655,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_zswapdatav end subroutine psi_zswapdatav
subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidxv use psi_mod, psb_protect_name => psi_zswapidxv
use psb_error_mod use psb_error_mod
@ -667,21 +669,21 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -695,7 +697,8 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -801,9 +804,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_complex,rcvbuf,rvsz,& & mpi_double_complex,rcvbuf,rvsz,&
& brvidx,mpi_double_complex,icomm,iret) & brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -866,7 +869,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -890,9 +893,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -913,9 +916,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1087,7 +1090,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_zswapdata_vect end subroutine psi_zswapdata_vect
subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_zswapidx_vect use psi_mod, psb_protect_name => psi_zswapidx_vect
use psb_error_mod use psb_error_mod
@ -1102,7 +1105,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
@ -1110,14 +1113,14 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1131,7 +1134,8 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
info=psb_err_context_error_ info=psb_err_context_error_
@ -1237,9 +1241,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_double_complex,rcvbuf,rvsz,& & mpi_double_complex,rcvbuf,rvsz,&
& brvidx,mpi_double_complex,icomm,iret) & brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1302,7 +1306,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1326,9 +1330,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1349,9 +1353,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
if ((proc_to_comm /= me).and.(nerv>0)) then if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

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

@ -111,7 +111,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -161,7 +161,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_zswaptranm end subroutine psi_zswaptranm
subroutine psi_ztranidxm(ictxt,icomm,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 psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod use psb_error_mod
@ -175,20 +175,27 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:,:), beta complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti
!!$ 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_
!!$ 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -202,6 +209,8 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -314,9 +323,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_double_complex,& & mpi_double_complex,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -379,7 +388,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -402,9 +411,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -426,9 +435,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -606,7 +615,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -657,7 +666,7 @@ end subroutine psi_zswaptranv
subroutine psi_ztranidxv(ictxt,icomm,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 psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod use psb_error_mod
@ -671,20 +680,27 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:) complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -698,6 +714,8 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -809,9 +827,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_complex,& & mpi_double_complex,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -874,7 +892,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -897,9 +915,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -920,9 +938,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then
@ -1049,7 +1067,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -1100,7 +1118,7 @@ end subroutine psi_zswaptran_vect
subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,& subroutine psi_ztranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ztranidx_vect use psi_mod, psb_protect_name => psi_ztranidx_vect
@ -1116,7 +1134,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta complex(psb_dpk_) :: beta
@ -1124,13 +1142,14 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals ! locals
integer(psb_ipk_) :: np, me, nesd, nerv,& integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
& iret, err_act, i, idx_pt, totsnd_, totrcv_,& integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& snd_pt, rcv_pt, pnti, data_, n
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd & sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: int_err(5) 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,& logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv & albf,do_send,do_recv
logical, parameter :: usersend=.false. logical, parameter :: usersend=.false.
@ -1144,6 +1163,8 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_ info=psb_success_
name='psi_swap_tran' name='psi_swap_tran'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
if (np == -1) then if (np == -1) then
@ -1255,9 +1276,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_double_complex,& & mpi_double_complex,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret) & sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -1320,7 +1341,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends ! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info) if (usersend) call mpi_barrier(icomm,iret)
pnti = 1 pnti = 1
snd_pt = 1 snd_pt = 1
@ -1343,9 +1364,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if end if
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
end if end if
@ -1366,9 +1387,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
if ((proc_to_comm /= me).and.(nesd>0)) then if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret) call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then if(iret /= mpi_success) then
int_err(1) = iret ierr(1) = iret
info=psb_err_mpi_error_ info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else if (proc_to_comm == me) then else if (proc_to_comm == me) then

Write Preview
Loading…
Cancel
Save