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. ! distributed dense matrix between all the processes.
! !
! Arguments: ! 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. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - complex(optional). Scale factor. ! alpha - complex(optional). Scale factor.

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

@ -42,7 +42,7 @@
! info - integer. Return code. ! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix ! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather. ! 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: ! update - integer(optional). Type of update:
! psb_none_ do nothing ! psb_none_ do nothing
! psb_sum_ sum of overlaps ! psb_sum_ sum of overlaps

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

@ -35,16 +35,15 @@
! This subroutine gathers pieces of a distributed dense matrix into a local one. ! This subroutine gathers pieces of a distributed dense matrix into a local one.
! !
! Arguments: ! Arguments:
! globx - integer(psb_ipk_),dimension(:,:). The local matrix into which gather ! globx - integer,dimension(:,:). The local matrix into which gather
! the distributed pieces. ! the distributed pieces.
! locx - integer(psb_ipk_),dimension(:,:). The local piece of the distributed ! locx - integer,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! Default: -1.
! !
subroutine psb_igatherm(globx, locx, desc_a, info, iroot) subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igatherm use psb_base_mod, psb_protect_name => psb_igatherm
@ -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_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_igatherm' name='psb_igatherm'
@ -82,7 +82,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)=root ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -206,15 +206,16 @@ end subroutine psb_igatherm
! This subroutine gathers pieces of a distributed dense vector into a local one. ! This subroutine gathers pieces of a distributed dense vector into a local one.
! !
! Arguments: ! Arguments:
! globx - integer(psb_ipk_),dimension(:). The local vector into which gather the ! globx - integer,dimension(:). The local vector into which gather
! distributed pieces. ! the distributed pieces.
! locx - integer(psb_ipk_),dimension(:). The local piece of the ditributed ! locx - integer,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
! the processes will have a copy. ! the processes will have a copy.
! default: -1
! !
subroutine psb_igatherv(globx, locx, desc_a, info, iroot) subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igatherv use psb_base_mod, psb_protect_name => psb_igatherv
@ -266,12 +267,12 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
jlocx=1 jlocx=1
ilocx = 1 ilocx = 1
lda_globx = size(globx)
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()
lda_globx = m
lda_locx = size(locx)
k = 1 k = 1
@ -293,6 +294,13 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if 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 globx(:)=izero
do i=1,desc_a%get_local_rows() do i=1,desc_a%get_local_rows()
@ -321,6 +329,7 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
end subroutine psb_igatherv end subroutine psb_igatherv
subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_igather_vect use psb_base_mod, psb_protect_name => psb_igather_vect
implicit none implicit none
@ -339,7 +348,7 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
integer(psb_ipk_), allocatable :: llocx(:) integer(psb_ipk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_igatherv' name='psb_cgatherv'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)

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

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

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

@ -29,6 +29,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
!
! File: psb_iovrl.f90 ! File: psb_iovrl.f90
! !
! Subroutine: psb_iovrlm ! Subroutine: psb_iovrlm
@ -41,7 +42,7 @@
! info - integer. Return code. ! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix ! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather. ! 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: ! update - integer(optional). Type of update:
! psb_none_ do nothing ! psb_none_ do nothing
! psb_sum_ sum of overlaps ! psb_sum_ sum of overlaps
@ -75,10 +76,10 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_mpik_) :: ictxt, np, me
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_ipk_), pointer :: iwork(:), xp(:,:) integer(psb_ipk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
@ -163,6 +164,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
else else
aliw=.true. aliw=.true.
end if end if
if (aliw) then if (aliw) then
allocate(iwork(liwork),stat=info) allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -175,7 +177,7 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
end if end if
! exchange overlap elements ! exchange overlap elements
if(do_swap) then if(do_swap) then
xp => x(iix:size(x,1),jjx:jjx+k-1) xp => x(iix:ldx,jjx:jjx+k-1)
call psi_swapdata(mode_,k,ione,xp,& call psi_swapdata(mode_,k,ione,xp,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
@ -195,7 +197,6 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
return return
end subroutine psb_iovrlm end subroutine psb_iovrlm
!!$ !!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
@ -236,7 +237,7 @@ end subroutine psb_iovrlm
! 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. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! work - real(optional). A work area. ! work - integer(optional). A work area.
! update - integer(optional). Type of update: ! update - integer(optional). Type of update:
! psb_none_ do nothing ! psb_none_ do nothing
! psb_sum_ sum of overlaps ! psb_sum_ sum of overlaps
@ -258,7 +259,6 @@ end subroutine psb_iovrlm
! previous call with swap_send) ! previous call with swap_send)
! !
! !
!
subroutine psb_iovrlv(x,desc_a,info,work,update,mode) subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrlv use psb_base_mod, psb_protect_name => psb_iovrlv
use psi_mod use psi_mod
@ -316,7 +316,6 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
mode_ = IOR(psb_swap_send_,psb_swap_recv_) mode_ = IOR(psb_swap_send_,psb_swap_recv_)
endif endif
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx)
@ -359,7 +358,7 @@ subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
! exchange overlap elements ! exchange overlap elements
if (do_swap) then if (do_swap) then
call psi_swapdata(mode_,ione,x(:),& call psi_swapdata(mode_,ione,x,&
& desc_a,iwork,info,data=psb_comm_ovr_) & desc_a,iwork,info,data=psb_comm_ovr_)
end if end if
if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) 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 return
end subroutine psb_iovrlv end subroutine psb_iovrlv
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrl_vect use psb_base_mod, psb_protect_name => psb_iovrl_vect
use psi_mod use psi_mod

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

@ -36,14 +36,15 @@
! into pieces that are local to alle the processes. ! into pieces that are local to alle the processes.
! !
! Arguments: ! Arguments:
! globx - integer(psb_ipk_),dimension(:,:). The global matrix to scatter. ! globx - integer,dimension(:,:). The global matrix to scatter.
! locx - integer(psb_ipk_),dimension(:,:). The local piece of the ditributed matrix. ! locx - integer,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all ! iroot - integer(optional). The process that owns the global matrix.
! the processes have a copy. ! If -1 all the processes have a copy.
! ! Default -1
subroutine psb_iscatterm(globx, locx, desc_a, info, iroot) subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
use psb_base_mod, psb_protect_name => psb_iscatterm use psb_base_mod, psb_protect_name => psb_iscatterm
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -59,12 +60,13 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
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 :: iroot
! locals ! locals
integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank 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,& 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, ilx,&
& jlx, c, pos & jlx, c, pos
integer(psb_ipk_), allocatable :: scatterv(:) integer(psb_ipk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -87,7 +89,7 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
ierr(1)=5; ierr(2)= root ierr(1)=5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -178,6 +180,15 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
! root has to gather loc_glob from each process ! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) 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 if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='Allocate' ch_err='Allocate'
@ -185,8 +196,6 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
goto 9999 goto 9999
end if end if
end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& 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)
@ -211,7 +220,14 @@ subroutine psb_iscatterm(globx, locx, desc_a, info, iroot)
end do 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 end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -263,10 +279,10 @@ end subroutine psb_iscatterm
! into pieces that are local to alle the processes. ! into pieces that are local to alle the processes.
! !
! Arguments: ! Arguments:
! globx - integer(psb_ipk_),dimension(:). The global vector to scatter. ! globx - integer,dimension(:). The global vector to scatter.
! locx - integer(psb_ipk_),dimension(:). The local piece of the ditributed vector. ! locx - integer,dimension(:). The local piece of the ditributed vector.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.
! !
@ -317,7 +333,7 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
root = iroot root = iroot
if((root < -1).or.(root > np)) then if((root < -1).or.(root > np)) then
info=psb_err_input_value_invalid_i_ info=psb_err_input_value_invalid_i_
ierr(1) = 5; ierr(2) = root ierr(1) = 5; ierr(2)=root
call psb_errpush(info,name,i_err=ierr) call psb_errpush(info,name,i_err=ierr)
goto 9999 goto 9999
end if end if
@ -369,7 +385,14 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
call psb_get_rank(rootrank,ictxt,root) call psb_get_rank(rootrank,ictxt,root)
! root has to gather size information ! 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 do i=1, nrow
ltg(i) = i ltg(i) = i
end do end do
@ -390,7 +413,22 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
endif endif
! root has to gather loc_glob from each process ! root has to gather loc_glob from each process
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim))) 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 end if
call mpi_gatherv(ltg,nrow,& 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,locx,nrow,&
& psb_mpi_ipk_integer,rootrank,icomm,info) & 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 end if
call psb_erractionrestore(err_act) 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. ! distributed dense matrix between all the processes.
! !
! Arguments: ! 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. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - complex(optional). Scale factor. ! alpha - complex(optional). Scale factor.

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

@ -42,7 +42,7 @@
! info - integer. Return code. ! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix ! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather. ! 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: ! update - integer(optional). Type of update:
! psb_none_ do nothing ! psb_none_ do nothing
! psb_sum_ sum of overlaps ! psb_sum_ sum of overlaps

Write Preview
Loading…
Cancel
Save