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_chalo.f90
 base/comm/psb_covrl.f90
 base/comm/psb_igather.f90
 base/comm/psb_ihalo.f90
 base/comm/psb_iovrl.f90
 base/comm/psb_iscatter.F90
 base/comm/psb_zhalo.f90
 base/comm/psb_zovrl.f90

Fix: I comm routines, internal comments in C/Z.
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent 9ac659aab9
commit 41bd66df18
8 changed files with 208 additions and 163 deletions
Show Stats Download Patch File Download Diff File

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

@ -36,7 +36,7 @@
! distributed dense matrix between all the processes.
!
! Arguments:
! x - real,dimension(:,:). The local part of the dense matrix.
! x - complex,dimension(:,:). The local part of the dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! alpha - complex(optional). Scale factor.

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

@ -42,7 +42,7 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps

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

@ -35,23 +35,22 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one.
!
! Arguments:
! globx - integer(psb_ipk_),dimension(:,:). The local matrix into which gather
! the distributed pieces.
! locx - integer(psb_ipk_),dimension(:,:). The local piece of the distributed
! matrix to be gathered.
! globx - integer,dimension(:,:). The local matrix into which gather
! the distributed pieces.
! locx - integer,dimension(:,:). The local piece of the distributed
! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! Default: -1.
!
subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igatherm
implicit none
integer(psb_ipk_), intent(in) :: locx(:,:)
integer(psb_ipk_), intent(out), allocatable :: globx(:,:)
integer(psb_ipk_), intent(out), allocatable :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
@ -61,6 +60,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err
name='psb_igatherm'
@ -82,7 +82,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
@ -127,7 +127,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
call psb_errpush(info,name)
goto 9999
end if
call psb_realloc(m,k,globx,info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
@ -162,7 +162,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
9999 call psb_error_handler(ictxt,err_act)
return
return
end subroutine psb_igatherm
@ -206,15 +206,16 @@ end subroutine psb_igatherm
! This subroutine gathers pieces of a distributed dense vector into a local one.
!
! Arguments:
! globx - integer(psb_ipk_),dimension(:). The local vector into which gather the
! distributed pieces.
! locx - integer(psb_ipk_),dimension(:). The local piece of the ditributed
! globx - integer,dimension(:). The local vector into which gather
! the distributed pieces.
! locx - integer,dimension(:). The local piece of the distributed
! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer. The process that has to own the
! global matrix. If -1 all
! the processes will have a copy.
! default: -1
!
subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igatherv
@ -266,12 +267,12 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
jlocx=1
ilocx = 1
lda_globx = size(globx)
lda_locx = size(locx)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
lda_globx = m
lda_locx = size(locx)
k = 1
@ -292,14 +293,21 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
call psb_errpush(info,name)
goto 9999
end if
call psb_realloc(m,globx,info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
globx(:)=izero
do i=1,desc_a%get_local_rows()
call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = locx(i)
end do
! adjust overlapped elements
do i=1, size(desc_a%ovrlap_elem,1)
if (me /= desc_a%ovrlap_elem(i,3)) then
@ -308,7 +316,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
globx(idx) = izero
end if
end do
call psb_sum(ictxt,globx(1:m),root=root)
call psb_erractionrestore(err_act)
@ -316,11 +324,12 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
9999 call psb_error_handler(ictxt,err_act)
return
return
end subroutine psb_igatherv
subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igather_vect
implicit none
@ -339,7 +348,7 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
integer(psb_ipk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
name='psb_igatherv'
name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
@ -429,6 +438,6 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
9999 call psb_error_handler(ictxt,err_act)
return
return
end subroutine psb_igather_vect

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

@ -29,7 +29,6 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_ihalo.f90
!
! Subroutine: psb_ihalom
@ -37,13 +36,13 @@
! distributed dense matrix between all the processes.
!
! Arguments:
! x - integer(psb_ipk_),dimension(:,:). The local part of the dense matrix.
! x - integer,dimension(:,:). The local part of the dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! alpha - real(optional). Scale factor.
! alpha - integer(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -59,19 +58,19 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
use psi_mod
implicit none
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, k, maxk, liwork,&
& imode, err,data_, ldx
integer(psb_ipk_), pointer :: xp(:,:), iwork(:)
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx
integer(psb_ipk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
@ -103,7 +102,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
nrow = desc_a%get_local_rows()
maxk=size(x,2)-ijx+1
if(present(ik)) then
if(ik > maxk) then
k=maxk
@ -119,20 +118,17 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
tran_ = 'N'
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
endif
if (present(mode)) then
imode = mode
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
endif
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
@ -151,15 +147,13 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
call psb_errcomm(ictxt,err)
if(err /= 0) goto 9999
! we should write an "iscal"
!!$ if(present(alpha)) then
!!$ if(alpha /= 1.d0) then
!!$ do i=0, k-1
!!$ call iscal(nrow,alpha,x(1,jjx+i),1)
!!$ end do
!!$ end if
!!$ end if
if(present(alpha)) then
if(alpha /= ione) then
do i=0, k-1
call iscal(int(nrow,kind=psb_mpik_),alpha,x(:,jjx+i),1)
end do
end if
end if
liwork=nrow
if (present(work)) then
@ -179,6 +173,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
@ -187,14 +182,14 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
end if
end if
xp => x(iix:ldx,jjx:jjx+k-1)
! exchange halo elements
xp => x(iix:size(x,1),jjx:jjx+k-1)
if(tran_ == 'N') then
call psi_swapdata(imode,k,izero,xp,&
& desc_a,iwork,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,k,ione,xp,&
& desc_a,iwork,info)
&desc_a,iwork,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -202,7 +197,8 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iSwap...')
ch_err='PSI_cswapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@ -251,19 +247,19 @@ end subroutine psb_ihalom
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! Subroutine: psb_ihalov
! This subroutine performs the exchange of the halo elements in a
! distributed dense matrix between all the processes.
! distributed dense vector between all the processes.
!
! Arguments:
! x - integer(psb_ipk_),dimension(:). The local part of the dense matrix.
! x - real,dimension(:). The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! alpha - real(optional). Scale factor.
! alpha - integer(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -279,19 +275,19 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
use psi_mod
implicit none
integer(psb_ipk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork, data_,ldx
integer(psb_ipk_),pointer :: iwork(:)
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
@ -317,8 +313,6 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
m = desc_a%get_global_rows()
n = desc_a%get_global_cols()
nrow = desc_a%get_local_rows()
! ncol = desc_a%get_local_cols()
if (present(tran)) then
tran_ = psb_toupper(tran)
@ -335,7 +329,6 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
else
imode = IOR(psb_swap_send_,psb_swap_recv_)
endif
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
@ -354,11 +347,11 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
call psb_errcomm(ictxt,err)
if(err /= 0) goto 9999
!!$ if(present(alpha)) then
!!$ if(alpha /= 1.d0) then
!!$ call dscal(nrow,alpha,x,1)
!!$ end if
!!$ end if
if(present(alpha)) then
if(alpha /= ione) then
call iscal(int(nrow,kind=psb_mpik_),alpha,x,ione)
end if
end if
liwork=nrow
if (present(work)) then
@ -400,7 +393,8 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='PSI_iswapdata')
ch_err='PSI_swapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
@ -416,8 +410,6 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
end subroutine psb_ihalov
subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ihalo_vect
use psi_mod
@ -502,7 +494,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
if(err /= 0) goto 9999
if(present(alpha)) then
if(alpha /= done) then
if(alpha /= ione) then
call x%scal(alpha)
end if
end if

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

@ -29,11 +29,12 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
! File: psb_iovrl.f90
!
! Subroutine: psb_iovrlm
! This subroutine performs the exchange of the overlap elements in a
! distributed dense matrix between all the processes.
! distributed dense matrix between all the processes.
!
! Arguments:
! x(:,:) - integer The local part of the dense matrix.
@ -41,7 +42,7 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -69,19 +70,19 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
implicit none
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
integer(psb_mpik_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_), pointer :: iwork(:), xp(:,:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
integer(psb_ipk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_iovrlm'
if(psb_get_errstatus() /= 0) return
@ -163,6 +164,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
@ -175,7 +177,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if
! exchange overlap elements
if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1)
xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,ione,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
@ -195,7 +197,6 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
return
end subroutine psb_iovrlm
!!$
!!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015
@ -230,18 +231,18 @@ end subroutine psb_iovrlm
!
! Subroutine: psb_iovrlv
! This subroutine performs the exchange of the overlap elements in a
! distributed dense vector between all the processes.
! distributed dense vector between all the processes.
!
! Arguments:
! x(:) - integer The local part of the dense vector.
! x(:) - integer The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! work - real(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
! psb_avg_ average of overlaps
! mode - integer(optional). Choose the algorithm for data exchange:
! info - integer. Return code.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
! psb_avg_ average of overlaps
! mode - integer(optional). Choose the algorithm for data exchange:
! this is chosen through bit fields.
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! - swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -258,23 +259,22 @@ end subroutine psb_iovrlm
! previous call with swap_send)
!
!
!
subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrlv
use psi_mod
implicit none
integer(psb_ipk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_),pointer :: iwork(:)
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
@ -316,8 +316,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif
do_swap = (mode_ /= 0)
ldx = size(x,1)
ldx = size(x,1)
! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then
@ -359,7 +358,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,ione,x(:),&
call psi_swapdata(mode_,ione,x,&
& desc_a,iwork,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info)
@ -379,6 +378,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
return
end subroutine psb_iovrlv
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrl_vect
use psi_mod

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

@ -36,14 +36,15 @@
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - integer(psb_ipk_),dimension(:,:). The global matrix to scatter.
! locx - integer(psb_ipk_),dimension(:,:). The local piece of the ditributed matrix.
! globx - integer,dimension(:,:). The global matrix to scatter.
! locx - integer,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all
! the processes have a copy.
!
! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy.
! Default -1
subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_iscatterm
#ifdef MPI_MOD
use mpi
@ -59,13 +60,14 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iroot
! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, ilx,&
& jlx, c, pos
integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
integer(psb_ipk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
name='psb_scatterm'
@ -87,14 +89,14 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)= root
ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
end if
if (root == -1) then
if (root == -1) then
iiroot = psb_root_
endif
@ -178,13 +180,20 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
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
call mpi_gatherv(ltg,nrow,&
@ -211,7 +220,14 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
end do
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,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
end if
call psb_erractionrestore(err_act)
@ -263,10 +279,10 @@ end subroutine psb_iscatterm
! into pieces that are local to alle the processes.
!
! Arguments:
! globx - integer(psb_ipk_),dimension(:). The global vector to scatter.
! locx - integer(psb_ipk_),dimension(:). The local piece of the ditributed vector.
! globx - integer,dimension(:). The global vector to scatter.
! locx - integer,dimension(:). The local piece of the ditributed vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code.
! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy.
!
@ -292,8 +308,8 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_ipk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit
name='psb_scatterv'
@ -314,17 +330,17 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
endif
if (present(iroot)) then
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2) = root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
root = iroot
if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else
root = -1
root = -1
end if
call psb_get_mpicomm(ictxt,icomm)
call psb_get_rank(myrank,ictxt,me)
@ -345,16 +361,16 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
if (info == psb_success_) &
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=psb_err_from_subroutine_
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name)
goto 9999
end if
nrow = desc_a%get_local_rows()
@ -369,7 +385,14 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information
allocate(displ(np),all_dim(np),ltg(nrow))
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
@ -388,9 +411,24 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim)
endif
! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)))
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
else
!
! This is to keep debugging compilers from being upset by
! calling an external MPI function with an unallocated array;
! the Fortran side would complain even if the MPI side does
! not use the unallocated stuff.
!
allocate(l_t_g_all(1),scatterv(1),stat=info)
end if
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
call mpi_gatherv(ltg,nrow,&
@ -413,7 +451,13 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
& psb_mpi_ipk_integer,locx,nrow,&
& psb_mpi_ipk_integer,rootrank,icomm,info)
if (me == root) deallocate(all_dim, l_t_g_all, displ, scatterv)
deallocate(all_dim, l_t_g_all, displ, ltg, scatterv,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
end if
call psb_erractionrestore(err_act)

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

@ -36,7 +36,7 @@
! distributed dense matrix between all the processes.
!
! Arguments:
! x - real,dimension(:,:). The local part of the dense matrix.
! x - complex,dimension(:,:). The local part of the dense matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! alpha - complex(optional). Scale factor.

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

@ -42,7 +42,7 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps

Write Preview
Loading…
Cancel
Save