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

psblas3:

Browse Source 
base/comm/psb_cscatter.F90
 base/comm/psb_dscatter.F90
 base/comm/psb_iscatter.F90
 base/comm/psb_sscatter.F90
 base/comm/psb_zscatter.F90
 base/modules/psb_c_comm_mod.f90
 base/modules/psb_d_comm_mod.f90
 base/modules/psb_i_comm_mod.f90
 base/modules/psb_s_comm_mod.f90
 base/modules/psb_z_comm_mod.f90
 docs/psblas-3.4.pdf
 docs/src/commrout.tex
 docs/src/datastruct.tex

Make LOCX an ALLOCATABLE arg.
psblas-3.4-maint
Salvatore Filippone 9 years ago
parent 0f5b146522
commit 15a14b4124
13 changed files with 857 additions and 900 deletions
Show Stats Download Patch File Download Diff File

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

@ -43,7 +43,7 @@
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
subroutine psb_cscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_cscatterm
#ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
complex(psb_spk_), intent(out) :: locx(:,:)
complex(psb_spk_), intent(out), allocatable :: locx(:,:)
complex(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
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
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
complex(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
k = maxk
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
lda_globx = size(globx)
lda_locx = size(locx)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
call psb_bcast(ictxt,k,root=iroot)
call psb_bcast(ictxt,lda_globx,root=iroot)
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
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'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
nrow=desc_a%get_local_rows()
if ((root == -1).or.(np == 1)) then
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
locx(i,j)=globx(ltg(i),j)
end do
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
@ -200,27 +189,26 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do c=1, k
do col=1, k
! prepare vector to scatter
if(me == root) then
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,jglobx+c-1)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter !!!
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_c_spk_,locx(1,jlocx+c-1),nrow,&
& psb_mpi_c_spk_,locx(1,col),nrow,&
& psb_mpi_c_spk_,rootrank,icomm,info)
end do
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -286,7 +281,7 @@ end subroutine psb_cscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
subroutine psb_cscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_cscatterv
#ifdef MPI_MOD
use mpi
@ -296,15 +291,15 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
complex(psb_spk_), intent(out) :: locx(:)
complex(psb_spk_), intent(out), allocatable :: locx(:)
complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, iam, iroot, 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(:)
@ -322,34 +317,33 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
call psb_get_rank(myrank,ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -358,8 +352,6 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
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'
@ -367,48 +359,39 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((root == -1).or.(np == 1)) then
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i)=globx(idx)
locx(i)=globx(ltg(i))
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
@ -436,7 +419,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter
if (me == root) then
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
@ -451,7 +434,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_c_spk_,locx,nrow,&
& psb_mpi_c_spk_,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -469,8 +460,6 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_cscatterv
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_cscatterv
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_cscatter_vect(globx, locx, desc_a, info, iroot, mold)
subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold)
use psb_base_mod, psb_protect_name => psb_cscatter_vect
implicit none
type(psb_c_vect_type), intent(inout) :: locx
complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
class(psb_c_base_vect_type), intent(in), optional :: mold
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, 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 :: vlocx(:)
@ -536,16 +525,15 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, iroot, mold)
call psb_errpush(info,name)
goto 9999
endif
call psb_geall(vlocx,desc_a,info)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, iroot)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999
endif
call locx%bld(vlocx,mold)
call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act)
return

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

@ -43,7 +43,7 @@
! 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)
subroutine psb_dscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_dscatterm
#ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
real(psb_dpk_), intent(out) :: locx(:,:)
real(psb_dpk_), intent(out), allocatable :: locx(:,:)
real(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
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
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
real(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
k = maxk
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
lda_globx = size(globx)
lda_locx = size(locx)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
call psb_bcast(ictxt,k,root=iroot)
call psb_bcast(ictxt,lda_globx,root=iroot)
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
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'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
nrow=desc_a%get_local_rows()
if ((root == -1).or.(np == 1)) then
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
locx(i,j)=globx(ltg(i),j)
end do
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
@ -200,27 +189,26 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do c=1, k
do col=1, k
! prepare vector to scatter
if(me == root) then
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,jglobx+c-1)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter !!!
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_r_dpk_,locx(1,jlocx+c-1),nrow,&
& psb_mpi_r_dpk_,locx(1,col),nrow,&
& psb_mpi_r_dpk_,rootrank,icomm,info)
end do
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -286,7 +281,7 @@ end subroutine psb_dscatterm
! 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)
subroutine psb_dscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_dscatterv
#ifdef MPI_MOD
use mpi
@ -296,15 +291,15 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
real(psb_dpk_), intent(out) :: locx(:)
real(psb_dpk_), intent(out), allocatable :: locx(:)
real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, iam, iroot, 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(:)
@ -322,34 +317,33 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
call psb_get_rank(myrank,ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -358,8 +352,6 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
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'
@ -367,48 +359,39 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((root == -1).or.(np == 1)) then
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i)=globx(idx)
locx(i)=globx(ltg(i))
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
@ -436,7 +419,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter
if (me == root) then
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
@ -451,7 +434,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_r_dpk_,locx,nrow,&
& psb_mpi_r_dpk_,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -469,8 +460,6 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_dscatterv
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_dscatterv
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dscatter_vect(globx, locx, desc_a, info, iroot, mold)
subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold)
use psb_base_mod, psb_protect_name => psb_dscatter_vect
implicit none
type(psb_d_vect_type), intent(inout) :: locx
real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
class(psb_d_base_vect_type), intent(in), optional :: mold
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, 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 :: vlocx(:)
@ -536,16 +525,15 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, iroot, mold)
call psb_errpush(info,name)
goto 9999
endif
call psb_geall(vlocx,desc_a,info)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, iroot)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999
endif
call locx%bld(vlocx,mold)
call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act)
return

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

@ -43,7 +43,7 @@
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
subroutine psb_iscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_iscatterm
#ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
integer(psb_ipk_), intent(out) :: locx(:,:)
integer(psb_ipk_), intent(out), allocatable :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
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
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
integer(psb_ipk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
k = maxk
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
lda_globx = size(globx)
lda_locx = size(locx)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
call psb_bcast(ictxt,k,root=iroot)
call psb_bcast(ictxt,lda_globx,root=iroot)
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
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'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
nrow=desc_a%get_local_rows()
if ((root == -1).or.(np == 1)) then
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
locx(i,j)=globx(ltg(i),j)
end do
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
@ -200,27 +189,26 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do c=1, k
do col=1, k
! prepare vector to scatter
if(me == root) then
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,jglobx+c-1)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter !!!
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_ipk_integer,locx(1,jlocx+c-1),nrow,&
& psb_mpi_ipk_integer,locx(1,col),nrow,&
& psb_mpi_ipk_integer,rootrank,icomm,info)
end do
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -286,7 +281,7 @@ end subroutine psb_iscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
subroutine psb_iscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_iscatterv
#ifdef MPI_MOD
use mpi
@ -296,15 +291,15 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
integer(psb_ipk_), intent(out) :: locx(:)
integer(psb_ipk_), intent(out), allocatable :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, iam, iroot, 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(:)
@ -322,34 +317,33 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
call psb_get_rank(myrank,ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -358,8 +352,6 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
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'
@ -367,48 +359,39 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((root == -1).or.(np == 1)) then
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i)=globx(idx)
locx(i)=globx(ltg(i))
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
@ -436,7 +419,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter
if (me == root) then
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
@ -451,7 +434,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,locx,nrow,&
& psb_mpi_ipk_integer,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -469,8 +460,6 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_iscatterv
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_iscatterv
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_iscatter_vect(globx, locx, desc_a, info, iroot, mold)
subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold)
use psb_base_mod, psb_protect_name => psb_iscatter_vect
implicit none
type(psb_i_vect_type), intent(inout) :: locx
integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
class(psb_i_base_vect_type), intent(in), optional :: mold
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, 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 :: vlocx(:)
@ -536,16 +525,15 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, iroot, mold)
call psb_errpush(info,name)
goto 9999
endif
call psb_geall(vlocx,desc_a,info)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, iroot)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999
endif
call locx%bld(vlocx,mold)
call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act)
return

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

@ -43,7 +43,7 @@
! 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)
subroutine psb_sscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_sscatterm
#ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
real(psb_spk_), intent(out) :: locx(:,:)
real(psb_spk_), intent(out), allocatable :: locx(:,:)
real(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
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
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
real(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
k = maxk
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
lda_globx = size(globx)
lda_locx = size(locx)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
call psb_bcast(ictxt,k,root=iroot)
call psb_bcast(ictxt,lda_globx,root=iroot)
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
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'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
nrow=desc_a%get_local_rows()
if ((root == -1).or.(np == 1)) then
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
locx(i,j)=globx(ltg(i),j)
end do
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
@ -200,27 +189,26 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do c=1, k
do col=1, k
! prepare vector to scatter
if(me == root) then
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,jglobx+c-1)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter !!!
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_r_spk_,locx(1,jlocx+c-1),nrow,&
& psb_mpi_r_spk_,locx(1,col),nrow,&
& psb_mpi_r_spk_,rootrank,icomm,info)
end do
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -286,7 +281,7 @@ end subroutine psb_sscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
subroutine psb_sscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_sscatterv
#ifdef MPI_MOD
use mpi
@ -296,15 +291,15 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
real(psb_spk_), intent(out) :: locx(:)
real(psb_spk_), intent(out), allocatable :: locx(:)
real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, iam, iroot, 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(:)
@ -322,34 +317,33 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
call psb_get_rank(myrank,ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -358,8 +352,6 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
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'
@ -367,48 +359,39 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((root == -1).or.(np == 1)) then
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i)=globx(idx)
locx(i)=globx(ltg(i))
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
@ -436,7 +419,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter
if (me == root) then
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
@ -451,7 +434,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_r_spk_,locx,nrow,&
& psb_mpi_r_spk_,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -469,8 +460,6 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_sscatterv
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_sscatterv
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_sscatter_vect(globx, locx, desc_a, info, iroot, mold)
subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold)
use psb_base_mod, psb_protect_name => psb_sscatter_vect
implicit none
type(psb_s_vect_type), intent(inout) :: locx
real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
class(psb_s_base_vect_type), intent(in), optional :: mold
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, 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 :: vlocx(:)
@ -536,16 +525,15 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, iroot, mold)
call psb_errpush(info,name)
goto 9999
endif
call psb_geall(vlocx,desc_a,info)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, iroot)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999
endif
call locx%bld(vlocx,mold)
call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act)
return

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

@ -43,7 +43,7 @@
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
subroutine psb_zscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_zscatterm
#ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
complex(psb_dpk_), intent(out) :: locx(:,:)
complex(psb_dpk_), intent(out), allocatable :: locx(:,:)
complex(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
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
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos
complex(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context()
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1)=5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
k = maxk
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
lda_globx = size(globx)
lda_locx = size(locx)
if (iroot==-1) then
lda_globx = size(globx, 1)
k = size(globx,2)
else
if (iam==iroot) then
k = size(globx,2)
lda_globx = size(globx, 1)
end if
call psb_bcast(ictxt,k,root=iroot)
call psb_bcast(ictxt,lda_globx,root=iroot)
end if
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
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'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
nrow=desc_a%get_local_rows()
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
nrow=desc_a%get_local_rows()
if ((root == -1).or.(np == 1)) then
call psb_geall(locx,desc_a,info,n=k)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do j=1,k
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
locx(i,j)=globx(ltg(i),j)
end do
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then
if (iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1)+all_dim(i-1)
@ -200,27 +189,26 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do c=1, k
do col=1, k
! prepare vector to scatter
if(me == root) then
if(iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
idx=l_t_g_all(pos+j)
scatterv(pos+j)=globx(idx,jglobx+c-1)
scatterv(pos+j)=globx(idx,col)
end do
end do
end if
! scatter !!!
! scatter
call mpi_scatterv(scatterv,all_dim,displ,&
& psb_mpi_c_dpk_,locx(1,jlocx+c-1),nrow,&
& psb_mpi_c_dpk_,locx(1,col),nrow,&
& psb_mpi_c_dpk_,rootrank,icomm,info)
end do
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -286,7 +281,7 @@ end subroutine psb_zscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
subroutine psb_zscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_zscatterv
#ifdef MPI_MOD
use mpi
@ -296,15 +291,15 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h'
#endif
complex(psb_dpk_), intent(out) :: locx(:)
complex(psb_dpk_), intent(out), allocatable :: locx(:)
complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, iam, iroot, 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(:)
@ -322,34 +317,33 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid
call psb_info(ictxt, me, np)
call psb_info(ictxt, iam, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
if (present(root)) then
iroot = root
if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
ierr(1) = 5; ierr(2)=iroot
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
iroot = psb_root_
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
call psb_get_rank(myrank,ictxt,iam)
iglobx = 1
jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
lda_globx = size(globx, 1)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
@ -358,8 +352,6 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! there should be a global check on k here!!!
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'
@ -367,48 +359,39 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((root == -1).or.(np == 1)) then
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_geall(locx,desc_a,info)
if ((iroot == -1).or.(np == 1)) then
! extract my chunk
do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info)
locx(i)=globx(idx)
locx(i)=globx(ltg(i))
end do
else
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nrow
ltg(i) = i
end do
call psb_loc_to_glob(ltg(1:nrow),desc_a,info)
call psb_get_rank(rootrank,ictxt,iroot)
call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then
if(iam == iroot) then
displ(1)=0
do i=2,np
displ(i)=displ(i-1) + all_dim(i-1)
end do
if (debug_level >= psb_debug_inner_) then
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
@ -436,7 +419,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter
if (me == root) then
if (iam == iroot) then
do i=1,np
pos=displ(i)
do j=1, all_dim(i)
@ -451,7 +434,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_c_dpk_,locx,nrow,&
& psb_mpi_c_dpk_,rootrank,icomm,info)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,stat=info)
deallocate(l_t_g_all, scatterv,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
end if
end if
deallocate(all_dim, displ, ltg,stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='deallocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_erractionrestore(err_act)
return
@ -469,8 +460,6 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_zscatterv
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_zscatterv
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zscatter_vect(globx, locx, desc_a, info, iroot, mold)
subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold)
use psb_base_mod, psb_protect_name => psb_zscatter_vect
implicit none
type(psb_z_vect_type), intent(inout) :: locx
complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
integer(psb_ipk_), intent(in), optional :: root
class(psb_z_base_vect_type), intent(in), optional :: mold
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_mpik_) :: ictxt, np, me, 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 :: vlocx(:)
@ -536,16 +525,15 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, iroot, mold)
call psb_errpush(info,name)
goto 9999
endif
call psb_geall(vlocx,desc_a,info)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, iroot)
if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999
endif
call locx%bld(vlocx,mold)
call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act)
return

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

@ -120,19 +120,19 @@ module psb_c_comm_mod
interface psb_scatter
subroutine psb_cscatterm(globx, locx, desc_a, info, root)
subroutine psb_cscatterm(globx, locx, desc_a, info, root)
import
implicit none
complex(psb_spk_), intent(out) :: locx(:,:)
complex(psb_spk_), intent(out), allocatable :: locx(:,:)
complex(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_cscatterm
subroutine psb_cscatterv(globx, locx, desc_a, info, root)
subroutine psb_cscatterv(globx, locx, desc_a, info, root)
import
implicit none
complex(psb_spk_), intent(out) :: locx(:)
complex(psb_spk_), intent(out), allocatable :: locx(:)
complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_c_comm_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
class(psb_c_base_vect_type), intent(in), optional :: mold
class(psb_c_base_vect_type), intent(in), optional :: mold
end subroutine psb_cscatter_vect
end interface psb_scatter

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

@ -120,19 +120,19 @@ module psb_d_comm_mod
interface psb_scatter
subroutine psb_dscatterm(globx, locx, desc_a, info, root)
subroutine psb_dscatterm(globx, locx, desc_a, info, root)
import
implicit none
real(psb_dpk_), intent(out) :: locx(:,:)
real(psb_dpk_), intent(out), allocatable :: locx(:,:)
real(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_dscatterm
subroutine psb_dscatterv(globx, locx, desc_a, info, root)
subroutine psb_dscatterv(globx, locx, desc_a, info, root)
import
implicit none
real(psb_dpk_), intent(out) :: locx(:)
real(psb_dpk_), intent(out), allocatable :: locx(:)
real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_d_comm_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
class(psb_d_base_vect_type), intent(in), optional :: mold
class(psb_d_base_vect_type), intent(in), optional :: mold
end subroutine psb_dscatter_vect
end interface psb_scatter

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

@ -119,19 +119,19 @@ module psb_i_comm_mod
interface psb_scatter
subroutine psb_iscatterm(globx, locx, desc_a, info, root)
subroutine psb_iscatterm(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_ipk_), intent(out) :: locx(:,:)
integer(psb_ipk_), intent(out), allocatable :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_iscatterm
subroutine psb_iscatterv(globx, locx, desc_a, info, root)
subroutine psb_iscatterv(globx, locx, desc_a, info, root)
import
implicit none
integer(psb_ipk_), intent(out) :: locx(:)
integer(psb_ipk_), intent(out), allocatable :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
@ -145,7 +145,7 @@ module psb_i_comm_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
class(psb_i_base_vect_type), intent(in), optional :: mold
class(psb_i_base_vect_type), intent(in), optional :: mold
end subroutine psb_iscatter_vect
end interface psb_scatter

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

@ -120,19 +120,19 @@ module psb_s_comm_mod
interface psb_scatter
subroutine psb_sscatterm(globx, locx, desc_a, info, root)
subroutine psb_sscatterm(globx, locx, desc_a, info, root)
import
implicit none
real(psb_spk_), intent(out) :: locx(:,:)
real(psb_spk_), intent(out), allocatable :: locx(:,:)
real(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_sscatterm
subroutine psb_sscatterv(globx, locx, desc_a, info, root)
subroutine psb_sscatterv(globx, locx, desc_a, info, root)
import
implicit none
real(psb_spk_), intent(out) :: locx(:)
real(psb_spk_), intent(out), allocatable :: locx(:)
real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_s_comm_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
class(psb_s_base_vect_type), intent(in), optional :: mold
class(psb_s_base_vect_type), intent(in), optional :: mold
end subroutine psb_sscatter_vect
end interface psb_scatter

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

@ -120,19 +120,19 @@ module psb_z_comm_mod
interface psb_scatter
subroutine psb_zscatterm(globx, locx, desc_a, info, root)
subroutine psb_zscatterm(globx, locx, desc_a, info, root)
import
implicit none
complex(psb_dpk_), intent(out) :: locx(:,:)
complex(psb_dpk_), intent(out), allocatable :: locx(:,:)
complex(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_zscatterm
subroutine psb_zscatterv(globx, locx, desc_a, info, root)
subroutine psb_zscatterv(globx, locx, desc_a, info, root)
import
implicit none
complex(psb_dpk_), intent(out) :: locx(:)
complex(psb_dpk_), intent(out), allocatable :: locx(:)
complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_z_comm_mod
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
class(psb_z_base_vect_type), intent(in), optional :: mold
class(psb_z_base_vect_type), intent(in), optional :: mold
end subroutine psb_zscatter_vect
end interface psb_scatter

631
docs/psblas-3.4.pdf
View File

File diff suppressed because it is too large Load Diff

5
docs/src/commrout.tex
Unescape Escape View File

@ -510,7 +510,8 @@ Specified as: a structured data of type \descdata.
Scope: {\bf global} \\
Type: {\bf optional}\\
Intent: {\bf in}.\\
Specified as: an integer variable $-1\le root\le np-1$, default $-1$.
Specified as: an integer variable $-1\le root\le np-1$, default
\verb|psb_root_|, i.e. process 0.
\item[mold] The desired dynamic type for the internal vector storage.\\
Scope: {\bf local}.\\
Type: {\bf optional}.\\
@ -547,7 +548,7 @@ $glob\_x$. \\
Scope: {\bf local} \\
Type: {\bf required}\\
Intent: {\bf out}.\\
Specified as: a rank one or two array or an object of type \vdata\ containing numbers of the type
Specified as: a rank one or two ALLOCATABLE array or an object of type \vdata\ containing numbers of the type
indicated in Table~\ref{tab:scatter}.
\item[info] Error code.\\
Scope: {\bf local} \\

1
docs/src/datastruct.tex
Unescape Escape View File

@ -397,6 +397,7 @@ processes.
\label{sec:cd_constants}
\begin{description}
\item[psb\_none\_] Generic no-op;
\item[psb\_root\_] Default root process for broadcast and scatter operations;
\item[psb\_nohalo\_] Do not fetch halo elements;
\item[psb\_halo\_] Fetch halo elements from neighbouring processes;
\item[psb\_sum\_] Sum overlapped elements

Write Preview
Loading…
Cancel
Save