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. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! 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 use psb_base_mod, psb_protect_name => psb_cscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
complex(psb_spk_), intent(out) :: locx(:,:) complex(psb_spk_), intent(out), allocatable :: locx(:,:)
complex(psb_spk_), intent(in) :: globx(:,:) complex(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& jlx, c, pos & col,pos
complex(psb_spk_),allocatable :: scatterv(:) complex(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context() ictxt=desc_a%get_context()
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1) lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,me)
if (iroot==-1) then
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx) 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() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx /= 1).or.(iglobx /= 1)) then nrow=desc_a%get_local_rows()
info=psb_err_ix_n1_iy_n1_unsupported_ ! root has to gather size information
call psb_errpush(info,name) 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 goto 9999
end if 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() call psb_geall(locx,desc_a,info,n=k)
if ((root == -1).or.(np == 1)) then if ((iroot == -1).or.(np == 1)) then
! extract my chunk ! extract my chunk
do j=1,k do j=1,k
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i,j)=globx(ltg(i),j)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
end do end do
end do end do
else else
call psb_get_rank(rootrank,ictxt,root)
call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then if (iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1)+all_dim(i-1) 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,& & psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do col=1, k
do c=1, k
! prepare vector to scatter ! prepare vector to scatter
if(me == root) then if(iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(i) do j=1, all_dim(i)
idx=l_t_g_all(pos+j) 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 do end do
end if end if
! scatter !!! ! scatter
call mpi_scatterv(scatterv,all_dim,displ,& 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) & psb_mpi_c_spk_,rootrank,icomm,info)
end do 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -286,7 +281,7 @@ end subroutine psb_cscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_cscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -296,15 +291,15 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
complex(psb_spk_), intent(out) :: locx(:) complex(psb_spk_), intent(out), allocatable :: locx(:)
complex(psb_spk_), intent(in) :: globx(:) complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_spk_), allocatable :: scatterv(:) complex(psb_spk_), allocatable :: scatterv(:)
@ -322,34 +317,33 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,iam)
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1 ilocx = 1
jlocx = 1 jlocx = 1
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -367,48 +359,39 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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() 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 ! extract my chunk
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(ltg(i))
locx(i)=globx(idx)
end do end do
else else
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then if(iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1) + all_dim(i-1) displ(i)=displ(i-1) + all_dim(i-1)
end do end do
if (debug_level >= psb_debug_inner_) then 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) &' dim',all_dim(1:np), sum(all_dim)
endif endif
@ -436,7 +419,7 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (me == root) then if (iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(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_,locx,nrow,&
& psb_mpi_c_spk_,rootrank,icomm,info) & 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -469,8 +460,6 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_cscatterv end subroutine psb_cscatterv
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_cscatterv
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 use psb_base_mod, psb_protect_name => psb_cscatter_vect
implicit none implicit none
type(psb_c_vect_type), intent(inout) :: locx type(psb_c_vect_type), intent(inout) :: locx
complex(psb_spk_), intent(in) :: globx(:) complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 class(psb_c_base_vect_type), intent(in), optional :: mold
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_spk_), allocatable :: vlocx(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv') call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999 goto 9999
endif endif
call locx%bld(vlocx,mold) call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return 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. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! 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 use psb_base_mod, psb_protect_name => psb_dscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
real(psb_dpk_), intent(out) :: locx(:,:) real(psb_dpk_), intent(out), allocatable :: locx(:,:)
real(psb_dpk_), intent(in) :: globx(:,:) real(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& jlx, c, pos & col,pos
real(psb_dpk_),allocatable :: scatterv(:) real(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context() ictxt=desc_a%get_context()
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1) lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,me)
if (iroot==-1) then
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx) 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() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx /= 1).or.(iglobx /= 1)) then nrow=desc_a%get_local_rows()
info=psb_err_ix_n1_iy_n1_unsupported_ ! root has to gather size information
call psb_errpush(info,name) 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 goto 9999
end if 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() call psb_geall(locx,desc_a,info,n=k)
if ((root == -1).or.(np == 1)) then if ((iroot == -1).or.(np == 1)) then
! extract my chunk ! extract my chunk
do j=1,k do j=1,k
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i,j)=globx(ltg(i),j)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
end do end do
end do end do
else else
call psb_get_rank(rootrank,ictxt,root)
call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then if (iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1)+all_dim(i-1) 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,& & psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do col=1, k
do c=1, k
! prepare vector to scatter ! prepare vector to scatter
if(me == root) then if(iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(i) do j=1, all_dim(i)
idx=l_t_g_all(pos+j) 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 do end do
end if end if
! scatter !!! ! scatter
call mpi_scatterv(scatterv,all_dim,displ,& 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) & psb_mpi_r_dpk_,rootrank,icomm,info)
end do 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -286,7 +281,7 @@ end subroutine psb_dscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_dscatterv(globx, locx, desc_a, info, iroot) subroutine psb_dscatterv(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_dscatterv use psb_base_mod, psb_protect_name => psb_dscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -296,15 +291,15 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
real(psb_dpk_), intent(out) :: locx(:) real(psb_dpk_), intent(out), allocatable :: locx(:)
real(psb_dpk_), intent(in) :: globx(:) real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
real(psb_dpk_), allocatable :: scatterv(:) real(psb_dpk_), allocatable :: scatterv(:)
@ -322,34 +317,33 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,iam)
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1 ilocx = 1
jlocx = 1 jlocx = 1
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -367,48 +359,39 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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() 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 ! extract my chunk
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(ltg(i))
locx(i)=globx(idx)
end do end do
else else
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then if(iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1) + all_dim(i-1) displ(i)=displ(i-1) + all_dim(i-1)
end do end do
if (debug_level >= psb_debug_inner_) then 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) &' dim',all_dim(1:np), sum(all_dim)
endif endif
@ -436,7 +419,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (me == root) then if (iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(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_,locx,nrow,&
& psb_mpi_r_dpk_,rootrank,icomm,info) & 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -469,8 +460,6 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_dscatterv end subroutine psb_dscatterv
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_dscatterv
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 use psb_base_mod, psb_protect_name => psb_dscatter_vect
implicit none implicit none
type(psb_d_vect_type), intent(inout) :: locx type(psb_d_vect_type), intent(inout) :: locx
real(psb_dpk_), intent(in) :: globx(:) real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 class(psb_d_base_vect_type), intent(in), optional :: mold
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
real(psb_dpk_), allocatable :: vlocx(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv') call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999 goto 9999
endif endif
call locx%bld(vlocx,mold) call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return 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. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! 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 use psb_base_mod, psb_protect_name => psb_iscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(out) :: locx(:,:) integer(psb_ipk_), intent(out), allocatable :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:) integer(psb_ipk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& jlx, c, pos & col,pos
integer(psb_ipk_),allocatable :: scatterv(:) integer(psb_ipk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context() ictxt=desc_a%get_context()
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1) lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,me)
if (iroot==-1) then
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx) 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() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx /= 1).or.(iglobx /= 1)) then nrow=desc_a%get_local_rows()
info=psb_err_ix_n1_iy_n1_unsupported_ ! root has to gather size information
call psb_errpush(info,name) 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 goto 9999
end if 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() call psb_geall(locx,desc_a,info,n=k)
if ((root == -1).or.(np == 1)) then if ((iroot == -1).or.(np == 1)) then
! extract my chunk ! extract my chunk
do j=1,k do j=1,k
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i,j)=globx(ltg(i),j)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
end do end do
end do end do
else else
call psb_get_rank(rootrank,ictxt,root)
call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then if (iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1)+all_dim(i-1) 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,& & psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do col=1, k
do c=1, k
! prepare vector to scatter ! prepare vector to scatter
if(me == root) then if(iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(i) do j=1, all_dim(i)
idx=l_t_g_all(pos+j) 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 do end do
end if end if
! scatter !!! ! scatter
call mpi_scatterv(scatterv,all_dim,displ,& 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) & psb_mpi_ipk_integer,rootrank,icomm,info)
end do 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -286,7 +281,7 @@ end subroutine psb_iscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_iscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -296,15 +291,15 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(out) :: locx(:) integer(psb_ipk_), intent(out), allocatable :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:) integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_), allocatable :: scatterv(:)
@ -322,34 +317,33 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,iam)
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1 ilocx = 1
jlocx = 1 jlocx = 1
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -367,48 +359,39 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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() 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 ! extract my chunk
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(ltg(i))
locx(i)=globx(idx)
end do end do
else else
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then if(iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1) + all_dim(i-1) displ(i)=displ(i-1) + all_dim(i-1)
end do end do
if (debug_level >= psb_debug_inner_) then 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) &' dim',all_dim(1:np), sum(all_dim)
endif endif
@ -436,7 +419,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (me == root) then if (iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(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,locx,nrow,&
& psb_mpi_ipk_integer,rootrank,icomm,info) & 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -469,8 +460,6 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_iscatterv end subroutine psb_iscatterv
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_iscatterv
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 use psb_base_mod, psb_protect_name => psb_iscatter_vect
implicit none implicit none
type(psb_i_vect_type), intent(inout) :: locx type(psb_i_vect_type), intent(inout) :: locx
integer(psb_ipk_), intent(in) :: globx(:) integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 class(psb_i_base_vect_type), intent(in), optional :: mold
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_ipk_), allocatable :: vlocx(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv') call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999 goto 9999
endif endif
call locx%bld(vlocx,mold) call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return 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. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! 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 use psb_base_mod, psb_protect_name => psb_sscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
real(psb_spk_), intent(out) :: locx(:,:) real(psb_spk_), intent(out), allocatable :: locx(:,:)
real(psb_spk_), intent(in) :: globx(:,:) real(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& jlx, c, pos & col,pos
real(psb_spk_),allocatable :: scatterv(:) real(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context() ictxt=desc_a%get_context()
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1) lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,me)
if (iroot==-1) then
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx) 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() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx /= 1).or.(iglobx /= 1)) then nrow=desc_a%get_local_rows()
info=psb_err_ix_n1_iy_n1_unsupported_ ! root has to gather size information
call psb_errpush(info,name) 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 goto 9999
end if 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() call psb_geall(locx,desc_a,info,n=k)
if ((root == -1).or.(np == 1)) then if ((iroot == -1).or.(np == 1)) then
! extract my chunk ! extract my chunk
do j=1,k do j=1,k
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i,j)=globx(ltg(i),j)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
end do end do
end do end do
else else
call psb_get_rank(rootrank,ictxt,root)
call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then if (iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1)+all_dim(i-1) 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,& & psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do col=1, k
do c=1, k
! prepare vector to scatter ! prepare vector to scatter
if(me == root) then if(iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(i) do j=1, all_dim(i)
idx=l_t_g_all(pos+j) 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 do end do
end if end if
! scatter !!! ! scatter
call mpi_scatterv(scatterv,all_dim,displ,& 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) & psb_mpi_r_spk_,rootrank,icomm,info)
end do 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -286,7 +281,7 @@ end subroutine psb_sscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_sscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -296,15 +291,15 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
real(psb_spk_), intent(out) :: locx(:) real(psb_spk_), intent(out), allocatable :: locx(:)
real(psb_spk_), intent(in) :: globx(:) real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
real(psb_spk_), allocatable :: scatterv(:) real(psb_spk_), allocatable :: scatterv(:)
@ -322,34 +317,33 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,iam)
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1 ilocx = 1
jlocx = 1 jlocx = 1
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -367,48 +359,39 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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() 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 ! extract my chunk
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(ltg(i))
locx(i)=globx(idx)
end do end do
else else
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then if(iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1) + all_dim(i-1) displ(i)=displ(i-1) + all_dim(i-1)
end do end do
if (debug_level >= psb_debug_inner_) then 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) &' dim',all_dim(1:np), sum(all_dim)
endif endif
@ -436,7 +419,7 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (me == root) then if (iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(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_,locx,nrow,&
& psb_mpi_r_spk_,rootrank,icomm,info) & 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -469,8 +460,6 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_sscatterv end subroutine psb_sscatterv
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_sscatterv
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 use psb_base_mod, psb_protect_name => psb_sscatter_vect
implicit none implicit none
type(psb_s_vect_type), intent(inout) :: locx type(psb_s_vect_type), intent(inout) :: locx
real(psb_spk_), intent(in) :: globx(:) real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 class(psb_s_base_vect_type), intent(in), optional :: mold
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
real(psb_spk_), allocatable :: vlocx(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv') call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999 goto 9999
endif endif
call locx%bld(vlocx,mold) call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return 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. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
! Default -1 ! Default -1
subroutine psb_zscatterm(globx, locx, desc_a, info, iroot) subroutine psb_zscatterm(globx, locx, desc_a, info, root)
use psb_base_mod, psb_protect_name => psb_zscatterm use psb_base_mod, psb_protect_name => psb_zscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
@ -54,18 +54,18 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
complex(psb_dpk_), intent(out) :: locx(:,:) complex(psb_dpk_), intent(out), allocatable :: locx(:,:)
complex(psb_dpk_), intent(in) :: globx(:,:) complex(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& jlx, c, pos & col,pos
complex(psb_dpk_),allocatable :: scatterv(:) complex(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -78,101 +78,90 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
ictxt=desc_a%get_context() ictxt=desc_a%get_context()
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot >= np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
if (root == -1) then
iiroot = psb_root_
endif
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1
jlocx = 1
lda_globx = size(globx,1) lda_globx = size(globx,1)
lda_locx = size(locx, 1)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,me)
if (iroot==-1) then
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx) 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() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx /= 1).or.(iglobx /= 1)) then nrow=desc_a%get_local_rows()
info=psb_err_ix_n1_iy_n1_unsupported_ ! root has to gather size information
call psb_errpush(info,name) 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 goto 9999
end if 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() call psb_geall(locx,desc_a,info,n=k)
if ((root == -1).or.(np == 1)) then if ((iroot == -1).or.(np == 1)) then
! extract my chunk ! extract my chunk
do j=1,k do j=1,k
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i,j)=globx(ltg(i),j)
locx(i,jlocx+j-1)=globx(idx,jglobx+j-1)
end do end do
end do end do
else else
call psb_get_rank(rootrank,ictxt,root)
call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) then if (iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1)+all_dim(i-1) 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,& & psb_mpi_ipk_integer,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
do col=1, k
do c=1, k
! prepare vector to scatter ! prepare vector to scatter
if(me == root) then if(iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(i) do j=1, all_dim(i)
idx=l_t_g_all(pos+j) 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 do end do
end if end if
! scatter !!! ! scatter
call mpi_scatterv(scatterv,all_dim,displ,& 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) & psb_mpi_c_dpk_,rootrank,icomm,info)
end do 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -229,6 +217,13 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -286,7 +281,7 @@ end subroutine psb_zscatterm
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
subroutine psb_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 use psb_base_mod, psb_protect_name => psb_zscatterv
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -296,15 +291,15 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
include 'mpif.h' include 'mpif.h'
#endif #endif
complex(psb_dpk_), intent(out) :: locx(:) complex(psb_dpk_), intent(out), allocatable :: locx(:)
complex(psb_dpk_), intent(in) :: globx(:) complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot integer(psb_ipk_), intent(in), optional :: root
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_dpk_), allocatable :: scatterv(:) complex(psb_dpk_), allocatable :: scatterv(:)
@ -322,34 +317,33 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! check on blacs grid ! check on blacs grid
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
if (np == -1) then if (np == -1) then
info = psb_err_context_error_ info = psb_err_context_error_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (present(iroot)) then if (present(root)) then
root = iroot iroot = root
if((root < -1).or.(root > np)) then if((iroot < -1).or.(iroot > np)) then
info=psb_err_input_value_invalid_i_ 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) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
else else
root = -1 iroot = psb_root_
end if end if
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me) call psb_get_rank(myrank,ictxt,iam)
iglobx = 1 iglobx = 1
jglobx = 1 jglobx = 1
ilocx = 1 ilocx = 1
jlocx = 1 jlocx = 1
lda_globx = size(globx) lda_globx = size(globx, 1)
lda_locx = size(locx)
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() 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!!! ! there should be a global check on k here!!!
call psb_chkglobvect(m,n,lda_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,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
@ -367,48 +359,39 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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() 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 ! extract my chunk
do i=1, nrow do i=1, nrow
call psb_loc_to_glob(i,idx,desc_a,info) locx(i)=globx(ltg(i))
locx(i)=globx(idx)
end do end do
else else
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,iroot)
! 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 mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,&
& 1,psb_mpi_ipk_integer,rootrank,icomm,info) & 1,psb_mpi_ipk_integer,rootrank,icomm,info)
if(me == root) then if(iam == iroot) then
displ(1)=0 displ(1)=0
do i=2,np do i=2,np
displ(i)=displ(i-1) + all_dim(i-1) displ(i)=displ(i-1) + all_dim(i-1)
end do end do
if (debug_level >= psb_debug_inner_) then 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) &' dim',all_dim(1:np), sum(all_dim)
endif endif
@ -436,7 +419,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
& displ,psb_mpi_ipk_integer,rootrank,icomm,info) & displ,psb_mpi_ipk_integer,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (me == root) then if (iam == iroot) then
do i=1,np do i=1,np
pos=displ(i) pos=displ(i)
do j=1, all_dim(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_,locx,nrow,&
& psb_mpi_c_dpk_,rootrank,icomm,info) & 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='deallocate' ch_err='deallocate'
@ -460,6 +443,14 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
end if end if
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) call psb_erractionrestore(err_act)
return return
@ -469,8 +460,6 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
end subroutine psb_zscatterv end subroutine psb_zscatterv
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -502,18 +491,18 @@ end subroutine psb_zscatterv
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ 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 use psb_base_mod, psb_protect_name => psb_zscatter_vect
implicit none implicit none
type(psb_z_vect_type), intent(inout) :: locx type(psb_z_vect_type), intent(inout) :: locx
complex(psb_dpk_), intent(in) :: globx(:) complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info 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 class(psb_z_base_vect_type), intent(in), optional :: mold
! locals ! 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,& 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 & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
complex(psb_dpk_), allocatable :: vlocx(:) 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) call psb_errpush(info,name)
goto 9999 goto 9999
endif 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 if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_scatterv') call psb_errpush(info,name,a_err='psb_scatterv')
goto 9999 goto 9999
endif endif
call locx%bld(vlocx,mold) call locx%bld(vlocx,mold=mold)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return 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 interface psb_scatter
subroutine psb_cscatterm(globx, locx, desc_a, info, root) subroutine psb_cscatterm(globx, locx, desc_a, info, root)
import import
implicit none implicit none
complex(psb_spk_), intent(out) :: locx(:,:) complex(psb_spk_), intent(out), allocatable :: locx(:,:)
complex(psb_spk_), intent(in) :: globx(:,:) complex(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_cscatterm end subroutine psb_cscatterm
subroutine psb_cscatterv(globx, locx, desc_a, info, root) subroutine psb_cscatterv(globx, locx, desc_a, info, root)
import import
implicit none implicit none
complex(psb_spk_), intent(out) :: locx(:) complex(psb_spk_), intent(out), allocatable :: locx(:)
complex(psb_spk_), intent(in) :: globx(:) complex(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_c_comm_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root 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 subroutine psb_cscatter_vect
end interface psb_scatter 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 interface psb_scatter
subroutine psb_dscatterm(globx, locx, desc_a, info, root) subroutine psb_dscatterm(globx, locx, desc_a, info, root)
import import
implicit none implicit none
real(psb_dpk_), intent(out) :: locx(:,:) real(psb_dpk_), intent(out), allocatable :: locx(:,:)
real(psb_dpk_), intent(in) :: globx(:,:) real(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_dscatterm end subroutine psb_dscatterm
subroutine psb_dscatterv(globx, locx, desc_a, info, root) subroutine psb_dscatterv(globx, locx, desc_a, info, root)
import import
implicit none implicit none
real(psb_dpk_), intent(out) :: locx(:) real(psb_dpk_), intent(out), allocatable :: locx(:)
real(psb_dpk_), intent(in) :: globx(:) real(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_d_comm_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root 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 subroutine psb_dscatter_vect
end interface psb_scatter 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 interface psb_scatter
subroutine psb_iscatterm(globx, locx, desc_a, info, root) subroutine psb_iscatterm(globx, locx, desc_a, info, root)
import import
implicit none implicit none
integer(psb_ipk_), intent(out) :: locx(:,:) integer(psb_ipk_), intent(out), allocatable :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:) integer(psb_ipk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_iscatterm end subroutine psb_iscatterm
subroutine psb_iscatterv(globx, locx, desc_a, info, root) subroutine psb_iscatterv(globx, locx, desc_a, info, root)
import import
implicit none implicit none
integer(psb_ipk_), intent(out) :: locx(:) integer(psb_ipk_), intent(out), allocatable :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:) integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -145,7 +145,7 @@ module psb_i_comm_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root 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 subroutine psb_iscatter_vect
end interface psb_scatter 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 interface psb_scatter
subroutine psb_sscatterm(globx, locx, desc_a, info, root) subroutine psb_sscatterm(globx, locx, desc_a, info, root)
import import
implicit none implicit none
real(psb_spk_), intent(out) :: locx(:,:) real(psb_spk_), intent(out), allocatable :: locx(:,:)
real(psb_spk_), intent(in) :: globx(:,:) real(psb_spk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_sscatterm end subroutine psb_sscatterm
subroutine psb_sscatterv(globx, locx, desc_a, info, root) subroutine psb_sscatterv(globx, locx, desc_a, info, root)
import import
implicit none implicit none
real(psb_spk_), intent(out) :: locx(:) real(psb_spk_), intent(out), allocatable :: locx(:)
real(psb_spk_), intent(in) :: globx(:) real(psb_spk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_s_comm_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root 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 subroutine psb_sscatter_vect
end interface psb_scatter 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 interface psb_scatter
subroutine psb_zscatterm(globx, locx, desc_a, info, root) subroutine psb_zscatterm(globx, locx, desc_a, info, root)
import import
implicit none implicit none
complex(psb_dpk_), intent(out) :: locx(:,:) complex(psb_dpk_), intent(out), allocatable :: locx(:,:)
complex(psb_dpk_), intent(in) :: globx(:,:) complex(psb_dpk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_zscatterm end subroutine psb_zscatterm
subroutine psb_zscatterv(globx, locx, desc_a, info, root) subroutine psb_zscatterv(globx, locx, desc_a, info, root)
import import
implicit none implicit none
complex(psb_dpk_), intent(out) :: locx(:) complex(psb_dpk_), intent(out), allocatable :: locx(:)
complex(psb_dpk_), intent(in) :: globx(:) complex(psb_dpk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -146,7 +146,7 @@ module psb_z_comm_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root 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 subroutine psb_zscatter_vect
end interface psb_scatter 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} \\ Scope: {\bf global} \\
Type: {\bf optional}\\ Type: {\bf optional}\\
Intent: {\bf in}.\\ 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.\\ \item[mold] The desired dynamic type for the internal vector storage.\\
Scope: {\bf local}.\\ Scope: {\bf local}.\\
Type: {\bf optional}.\\ Type: {\bf optional}.\\
@ -547,7 +548,7 @@ $glob\_x$. \\
Scope: {\bf local} \\ Scope: {\bf local} \\
Type: {\bf required}\\ Type: {\bf required}\\
Intent: {\bf out}.\\ 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}. indicated in Table~\ref{tab:scatter}.
\item[info] Error code.\\ \item[info] Error code.\\
Scope: {\bf local} \\ Scope: {\bf local} \\

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

@ -397,6 +397,7 @@ processes.
\label{sec:cd_constants} \label{sec:cd_constants}
\begin{description} \begin{description}
\item[psb\_none\_] Generic no-op; \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\_nohalo\_] Do not fetch halo elements;
\item[psb\_halo\_] Fetch halo elements from neighbouring processes; \item[psb\_halo\_] Fetch halo elements from neighbouring processes;
\item[psb\_sum\_] Sum overlapped elements \item[psb\_sum\_] Sum overlapped elements

Write Preview
Loading…
Cancel
Save