fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 21:02:26 +00:00
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.
This commit is contained in:
Salvatore Filippone
2012-01-30 18:39:40 +00:00
parent 9c153be7ff
commit 72d52a981d
34 changed files with 1001 additions and 862 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/comm/psb_cgather.f90
+21 -21
View File
@@ -35,9 +35,9 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one.
!
! Arguments:
! globx - cplx,dimension(:,:). The local matrix into which gather
! globx - complex,dimension(:,:). The local matrix into which gather
! 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.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
@@ -57,8 +57,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
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
character(len=20) :: name, ch_err
@@ -82,8 +82,8 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -115,9 +115,9 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! 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_) &
& 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
info=psb_err_from_subroutine_
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.
!
! Arguments:
! globx - cplx,dimension(:). The local vector into which gather
! globx - complex,dimension(:). The local vector into which gather
! 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.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
@@ -230,8 +230,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err
@@ -255,8 +255,8 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -279,9 +279,9 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -341,8 +341,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
complex(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@@ -366,8 +366,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -390,7 +390,7 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
! 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,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
base/comm/psb_chalo.f90
+14 -13
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx
complex(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_
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
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
if(alpha /= cone) then
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 if
end if
@@ -289,7 +289,8 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran
! 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_
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
@@ -333,9 +334,9 @@ subroutine psb_chalov(x,desc_a,info,alpha,work,tran,mode,data)
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
call cscal(nrow,alpha,x,ione)
if(alpha /= cone) then
call cscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if
end if
@@ -486,7 +487,7 @@ subroutine psb_chalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_covrl.f90
+11 -11
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx
complex(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -177,7 +177,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
! exchange overlap elements
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,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
@@ -278,7 +278,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork, ldx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -403,7 +403,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork,ldx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_cscatter.F90
+15 -16
View File
@@ -62,10 +62,10 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
complex(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -89,8 +89,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -128,8 +128,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -295,10 +295,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,&
& rootrank, pos, ilx, jlx
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -325,8 +324,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -349,9 +348,9 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_cspgather.F90
+12 -9
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
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
logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
ierr(1) = 2*np
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
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)
call mpi_allgatherv(loc_coo%val,ndx,mpi_complex,&
& glob_coo%val,nzbr,idisp,&
& mpi_complex,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& mpi_complex,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& psb_mpi_integer,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& 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')
goto 9999
end if
base/comm/psb_dgather.f90
+32 -32
View File
@@ -36,15 +36,14 @@
!
! Arguments:
! globx - real,dimension(:,:). The local matrix into which gather
! the distributed pieces.
! the distributed pieces.
! 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.
! info - integer. Return code.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! Default: -1.
!
subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dgatherm
@@ -58,9 +57,10 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
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
character(len=20) :: name, ch_err
name='psb_dgatherm'
@@ -82,8 +82,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -115,9 +115,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! 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_) &
& 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
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -131,7 +131,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
goto 9999
end if
globx(:,:)=0.d0
globx(:,:)=dzero
do j=1,k
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.
!
! Arguments:
! globx - real,dimension(:). The local vector into which gather the
! distributed pieces.
! locx - real,dimension(:). The local piece of the ditributed
! globx - real,dimension(:). The local vector into which gather
! the distributed pieces.
! locx - real,dimension(:). The local piece of the distributed
! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! root - integer. The process that has to own the
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! default: -1
!
subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dgatherv
@@ -229,8 +230,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err
@@ -254,8 +255,8 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -272,15 +273,15 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -294,7 +295,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
goto 9999
end if
globx(:)=0.d0
globx(:)=dzero
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
@@ -333,20 +334,20 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
implicit none
type(psb_d_vect_type), intent(inout) :: locx
real(psb_dpk_), intent(out) :: globx(:)
real(psb_dpk_), intent(out) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
real(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
name='psb_dgatherv'
name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
@@ -365,8 +366,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -389,7 +390,7 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
! 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,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
@@ -408,7 +409,6 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
globx(:) = dzero
llocx = locx%get_vect()
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = llocx(i)
base/comm/psb_dhalo.f90
+14 -13
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx
real(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_
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
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
if(alpha /= done) then
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 if
end if
@@ -289,7 +289,8 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran
! 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_
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
@@ -333,9 +334,9 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
call dscal(nrow,alpha,x,ione)
if(alpha /= done) then
call dscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if
end if
@@ -486,7 +487,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_dovrl.f90
+11 -11
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx
real(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -177,7 +177,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
! exchange overlap elements
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,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
@@ -278,7 +278,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork, ldx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -403,7 +403,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork,ldx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_dscatter.F90
+27 -29
View File
@@ -36,13 +36,13 @@
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the ditributed matrix.
! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all
! the processes have a copy. Default -1.
!
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dscatterm
@@ -62,12 +62,12 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
real(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
real(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
name='psb_scatterm'
@@ -89,8 +89,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -128,8 +128,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -178,7 +178,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
displ(i)=displ(i-1)+all_dim(i-1)
end do
! root has to gather loc_glob from each process
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -270,16 +270,15 @@ end subroutine psb_dscatterm
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector.
! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector.
! 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
! the processes have a copy.
!
subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_dscatterv
#ifdef MPI_MOD
use mpi
#endif
@@ -296,12 +295,11 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,&
& rootrank, pos, ilx, jlx
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
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
integer(psb_ipk_) :: debug_level, debug_unit
@@ -326,8 +324,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -350,9 +348,9 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_dspgather.F90
+13 -10
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
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
logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
ierr(1) = 2*np
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
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))
enddo
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,&
& mpi_double_precision,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& mpi_complex,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& psb_mpi_integer,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& 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')
goto 9999
end if
base/comm/psb_igather.f90
+12 -12
View File
@@ -58,8 +58,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
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
character(len=20) :: name, ch_err
@@ -82,8 +82,8 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -115,9 +115,9 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
! 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_) &
& 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
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -229,8 +229,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err
@@ -254,8 +254,8 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -278,9 +278,9 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_ihalo.f90
+8 -6
View File
@@ -70,7 +70,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& 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(:)
character :: tran_
character(len=20) :: name, ch_err
@@ -103,7 +103,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
nrow = desc_a%get_local_rows()
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik > maxk) then
k=maxk
@@ -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_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
xp => x(iix:size(x,1),jjx:jjx+k-1)
xp => x(iix:ldx,jjx:jjx+k-1)
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,k,izero,xp,&
@@ -294,7 +295,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork, data_
& err, liwork, data_,ldx
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
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_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_iovrl.f90
+7 -6
View File
@@ -77,7 +77,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& 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(:,:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -278,7 +278,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork, ldx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@@ -321,9 +321,10 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_iscatter.F90
+15 -16
View File
@@ -60,10 +60,10 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -87,8 +87,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)= root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -126,8 +126,8 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -293,10 +293,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,&
& rootrank, pos, ilx, jlx
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -323,8 +322,8 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2) = root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -347,9 +346,9 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_sgather.f90
+30 -30
View File
@@ -36,15 +36,14 @@
!
! Arguments:
! globx - real,dimension(:,:). The local matrix into which gather
! the distributed pieces.
! the distributed pieces.
! 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.
! info - integer. Return code.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! Default: -1.
!
subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sgatherm
@@ -58,9 +57,10 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
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
character(len=20) :: name, ch_err
name='psb_sgatherm'
@@ -82,8 +82,8 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -115,9 +115,9 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! 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_) &
& 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
info=psb_err_from_subroutine_
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.
!
! Arguments:
! globx - real,dimension(:). The local vector into which gather the
! distributed pieces.
! locx - real,dimension(:). The local piece of the ditributed
! globx - real,dimension(:). The local vector into which gather
! the distributed pieces.
! locx - real,dimension(:). The local piece of the distributed
! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! root - integer. The process that has to own the
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! default: -1
!
subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sgatherv
@@ -229,8 +230,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err
@@ -254,8 +255,8 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -272,15 +273,15 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -333,20 +334,20 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
implicit none
type(psb_s_vect_type), intent(inout) :: locx
real(psb_spk_), intent(out) :: globx(:)
real(psb_spk_), intent(out) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
real(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
name='psb_dgatherv'
name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
@@ -365,8 +366,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -389,7 +390,7 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
! 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,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
@@ -408,7 +409,6 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
globx(:) = szero
llocx = locx%get_vect()
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = llocx(i)
base/comm/psb_shalo.f90
+14 -13
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx
real(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_
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
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
if(alpha /= sone) then
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 if
end if
@@ -289,7 +289,8 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran
! 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_
real(psb_spk_),pointer :: iwork(:)
character :: tran_
@@ -333,9 +334,9 @@ subroutine psb_shalov(x,desc_a,info,alpha,work,tran,mode,data)
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
call sscal(nrow,alpha,x,ione)
if(alpha /= sone) then
call sscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if
end if
@@ -486,7 +487,7 @@ subroutine psb_shalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_sovrl.f90
+11 -11
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx
real(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -177,7 +177,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
! exchange overlap elements
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,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
@@ -278,7 +278,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork, ldx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -403,7 +403,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork,ldx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_sscatter.F90
+29 -30
View File
@@ -36,16 +36,16 @@
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the ditributed matrix.
! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all
! the processes have a copy. Default -1.
!
subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sscatterm
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_sscatterm
#ifdef MPI_MOD
use mpi
#endif
@@ -62,12 +62,12 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
real(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
real(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
name='psb_scatterm'
@@ -89,8 +89,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -128,8 +128,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -178,7 +178,7 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
displ(i)=displ(i-1)+all_dim(i-1)
end do
! root has to gather loc_glob from each process
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -270,10 +270,10 @@ end subroutine psb_sscatterm
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector.
! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector.
! 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
! the processes have a copy.
!
@@ -295,12 +295,11 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,&
& rootrank, pos, ilx, jlx
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
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
integer(psb_ipk_) :: debug_level, debug_unit
@@ -325,8 +324,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -349,9 +348,9 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_sspgather.F90
+13 -10
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
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
logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
ierr(1) = 2*np
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
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))
enddo
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,&
& mpi_real,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& mpi_complex,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& psb_mpi_integer,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& 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')
goto 9999
end if
base/comm/psb_zgather.f90
+21 -21
View File
@@ -35,9 +35,9 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one.
!
! Arguments:
! globx - cplx,dimension(:,:). The local matrix into which gather
! globx - complex,dimension(:,:). The local matrix into which gather
! 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.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
@@ -57,8 +57,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, iiroot, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
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
character(len=20) :: name, ch_err
@@ -82,8 +82,8 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -115,9 +115,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! 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_) &
& 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
info=psb_err_from_subroutine_
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.
!
! Arguments:
! globx - cplx,dimension(:). The local vector into which gather
! globx - complex,dimension(:). The local vector into which gather
! 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.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
@@ -230,8 +230,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
character(len=20) :: name, ch_err
@@ -255,8 +255,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -279,9 +279,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -341,8 +341,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, n, root, ilocx, iglobx, jlocx,&
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
complex(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@@ -366,8 +366,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -390,7 +390,7 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
! 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,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
base/comm/psb_zhalo.f90
+14 -13
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_
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
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
if(alpha /= zone) then
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 if
end if
@@ -289,7 +289,8 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
character, intent(in), optional :: tran
! 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_
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
@@ -333,9 +334,9 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode,data)
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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(present(alpha)) then
if(alpha /= 1.d0) then
call zscal(nrow,alpha,x,ione)
if(alpha /= zone) then
call zscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if
end if
@@ -486,7 +487,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_zovrl.f90
+11 -11
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -177,7 +177,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
! exchange overlap elements
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,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
@@ -278,7 +278,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork, ldx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@@ -403,7 +403,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork
& mode_, err, liwork,ldx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
base/comm/psb_zscatter.F90
+16 -16
View File
@@ -44,6 +44,7 @@
! If -1 all the processes have a copy.
! Default -1
subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_zscatterm
#ifdef MPI_MOD
use mpi
@@ -61,10 +62,10 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me,&
& err_act, m, n, i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
complex(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -88,8 +89,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -127,8 +128,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx),iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,size(locx),ilocx,jlocx,desc_a,info,ilx,jlx)
call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info)
if (info == psb_success_) call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
@@ -294,10 +295,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_ipk_) :: int_err(5), ictxt, np, me, &
& err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, root, k, icomm, myrank,&
& rootrank, pos, ilx, jlx
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@@ -324,8 +324,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
@@ -348,9 +348,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
k = 1
! 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)
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
base/comm/psb_zspgather.F90
+14 -11
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
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
logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit
@@ -53,12 +55,12 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*np,0,0,0,0/),&
& a_err='integer')
ierr(1) = 2*np
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
call loca%mv_to(loc_coo)
nzbr(:) = 0
nzbr(:) = 0
nzbr(me+1) = loc_coo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr)
@@ -68,17 +70,18 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
idisp(ip) = sum(nzbr(1:ip-1))
enddo
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,&
& mpi_double_complex,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& mpi_complex,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_integer,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_integer,icomm,info)
if (info == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& psb_mpi_integer,icomm,minfo)
if (minfo == psb_success_) call mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_integer,&
& 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')
goto 9999
end if
base/internals/psi_cswapdata.F90
+54 -50
View File
@@ -156,7 +156,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -170,20 +170,21 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
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,&
& brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
@@ -395,9 +397,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -667,21 +669,21 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -801,9 +804,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_complex,rcvbuf,rvsz,&
& brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -890,9 +893,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -1102,7 +1105,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
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
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -1237,9 +1241,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_complex,rcvbuf,rvsz,&
& brvidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1326,9 +1330,9 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_cswaptran.F90
+69 -48
View File
@@ -111,7 +111,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
@@ -161,7 +161,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -175,20 +175,27 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
complex(psb_spk_) :: y(:,:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -314,9 +323,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -402,9 +411,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -606,7 +615,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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 psb_error_mod
@@ -671,20 +680,27 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
complex(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -809,9 +827,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -897,9 +915,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1049,7 +1067,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
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'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
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
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
@@ -1144,6 +1163,8 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -1255,9 +1276,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_complex,&
& sndbuf,sdsz,bsdidx,mpi_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@@ -1320,7 +1341,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1343,9 +1364,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_dswapdata.F90
+54 -50
View File
@@ -156,7 +156,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -170,20 +170,21 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
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,&
& brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
@@ -395,9 +397,9 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -667,21 +669,21 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -801,9 +804,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_precision,rcvbuf,rvsz,&
& brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -890,9 +893,9 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -1102,7 +1105,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
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
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -1237,9 +1241,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_double_precision,rcvbuf,rvsz,&
& brvidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1326,9 +1330,9 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_dswaptran.F90
+69 -48
View File
@@ -111,7 +111,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
@@ -161,7 +161,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -175,20 +175,27 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -402,9 +411,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -606,7 +615,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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 psb_error_mod
@@ -671,20 +680,27 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -897,9 +915,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1049,7 +1067,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
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'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
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
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
@@ -1144,6 +1163,8 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -1255,9 +1276,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_double_precision,&
& sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@@ -1320,7 +1341,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1343,9 +1364,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_iswapdata.F90
+55 -51
View File
@@ -156,7 +156,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -170,20 +170,21 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
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,&
& brvidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
@@ -395,9 +397,9 @@ subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -667,21 +669,21 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#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_) :: y(:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -801,9 +804,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& psb_mpi_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -890,9 +893,9 @@ subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1087,7 +1090,7 @@ end subroutine psi_iswapidxv
!!$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 psb_error_mod
@@ -1102,7 +1105,7 @@ end subroutine psi_iswapidxv
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
@@ -1110,14 +1113,14 @@ end subroutine psi_iswapidxv
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$
!!$ ! locals
!!$ integer(psb_ipk_) :: np, me, nesd, nerv,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
!!$ & iret, err_act, i, totsnd_, totrcv_,&
!!$ & idx_pt, snd_pt, rcv_pt, n, pnti, data_
!!$
!!$ integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: 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,&
!!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false.
@@ -1131,7 +1134,8 @@ end subroutine psi_iswapidxv
!!$ info=psb_success_
!!$ name='psi_swap_datav'
!!$ call psb_erractionsave(err_act)
!!$
!!$ ictxt = iictxt
!!$ icomm = iicomm
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
!!$ info=psb_err_context_error_
@@ -1237,9 +1241,9 @@ end subroutine psi_iswapidxv
!!$ & psb_mpi_integer,rcvbuf,rvsz,&
!!$ & brvidx,psb_mpi_integer,icomm,iret)
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
@@ -1302,7 +1306,7 @@ end subroutine psi_iswapidxv
!!$
!!$
!!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,info)
!!$ if (usersend) call mpi_barrier(icomm,iret)
!!$
!!$ pnti = 1
!!$ snd_pt = 1
@@ -1326,9 +1330,9 @@ end subroutine psi_iswapidxv
!!$ end if
!!$
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ end if
@@ -1349,9 +1353,9 @@ end subroutine psi_iswapidxv
!!$ if ((proc_to_comm /= me).and.(nerv>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ else if (proc_to_comm == me) then
@@ -1446,4 +1450,4 @@ end subroutine psi_iswapidxv
!!$ end if
!!$ return
!!$end subroutine psi_iswapidx_vect
!!$
base/internals/psi_iswaptran.F90
+69 -48
View File
@@ -111,7 +111,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
@@ -161,7 +161,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -175,20 +175,27 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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_) :: y(:,:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -402,9 +411,9 @@ subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -606,7 +615,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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 psb_error_mod
@@ -671,20 +680,27 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#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_) :: y(:), beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -897,9 +915,9 @@ subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1049,7 +1067,7 @@ end subroutine psi_itranidxv
!!$ ! locals
!!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
!!$ integer(psb_ipk_), pointer :: d_idx(:)
!!$ integer(psb_ipk_) :: int_err(5)
!!$ integer(psb_ipk_) :: ierr(5)
!!$ character(len=20) :: name
!!$
!!$ 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)
!!$
!!$ use psi_mod, psb_protect_name => psi_itranidx_vect
@@ -1116,7 +1134,7 @@ end subroutine psi_itranidxv
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
@@ -1124,13 +1142,14 @@ end subroutine psi_itranidxv
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$
!!$ ! locals
!!$ 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,&
!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: 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,&
!!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false.
@@ -1144,6 +1163,8 @@ end subroutine psi_itranidxv
!!$ info=psb_success_
!!$ name='psi_swap_tran'
!!$ call psb_erractionsave(err_act)
!!$ ictxt = iictxt
!!$ icomm = iicomm
!!$
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
@@ -1255,9 +1276,9 @@ end subroutine psi_itranidxv
!!$ & psb_mpi_integer,&
!!$ & sndbuf,sdsz,bsdidx,psb_mpi_integer,icomm,iret)
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
@@ -1320,7 +1341,7 @@ end subroutine psi_itranidxv
!!$
!!$
!!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,info)
!!$ if (usersend) call mpi_barrier(icomm,iret)
!!$
!!$ pnti = 1
!!$ snd_pt = 1
@@ -1343,9 +1364,9 @@ end subroutine psi_itranidxv
!!$ end if
!!$
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ end if
@@ -1366,9 +1387,9 @@ end subroutine psi_itranidxv
!!$ if ((proc_to_comm /= me).and.(nesd>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then
!!$ int_err(1) = iret
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ else if (proc_to_comm == me) then
base/internals/psi_sswapdata.F90
+54 -50
View File
@@ -156,7 +156,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -170,20 +170,21 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
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,&
& brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
@@ -395,9 +397,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -667,21 +669,21 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -801,9 +804,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_real,rcvbuf,rvsz,&
& brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -890,9 +893,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -1102,7 +1105,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
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
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -1237,9 +1241,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_real,rcvbuf,rvsz,&
& brvidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1326,9 +1330,9 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_sswaptran.F90
+69 -48
View File
@@ -111,7 +111,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
@@ -161,7 +161,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -175,20 +175,27 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -314,9 +323,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -402,9 +411,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -606,7 +615,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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 psb_error_mod
@@ -671,20 +680,27 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -809,9 +827,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -897,9 +915,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1049,7 +1067,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
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'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
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
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
@@ -1144,6 +1163,8 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -1255,9 +1276,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_real,&
& sndbuf,sdsz,bsdidx,mpi_real,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@@ -1320,7 +1341,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1343,9 +1364,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_zswapdata.F90
+54 -50
View File
@@ -156,7 +156,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -170,20 +170,21 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
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,&
& brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
@@ -395,9 +397,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -667,21 +669,21 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -801,9 +804,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& mpi_double_complex,rcvbuf,rvsz,&
& brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -890,9 +893,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
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
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 psb_error_mod
@@ -1102,7 +1105,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
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
! locals
integer(psb_ipk_) :: np, me, nesd, nerv,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, err_act, i, totsnd_, totrcv_,&
& idx_pt, snd_pt, rcv_pt, n, pnti, data_
integer(psb_ipk_), allocatable, dimension(:) :: bsdidx, brvidx,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
@@ -1237,9 +1241,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& mpi_double_complex,rcvbuf,rvsz,&
& brvidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1326,9 +1330,9 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
base/internals/psi_zswaptran.F90
+69 -48
View File
@@ -111,7 +111,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
@@ -161,7 +161,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
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 psb_error_mod
@@ -175,20 +175,27 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
include 'mpif.h'
#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
complex(psb_dpk_) :: y(:,:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -402,9 +411,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -606,7 +615,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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 psb_error_mod
@@ -671,20 +680,27 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
complex(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
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_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
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,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -897,9 +915,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
@@ -1049,7 +1067,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: int_err(5)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
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)
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'
#endif
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
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
! locals
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,&
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: 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,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
@@ -1144,6 +1163,8 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
@@ -1255,9 +1276,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& mpi_double_complex,&
& sndbuf,sdsz,bsdidx,mpi_double_complex,icomm,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@@ -1320,7 +1341,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,info)
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
@@ -1343,9 +1364,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
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
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
int_err(1) = iret
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=int_err)
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then