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

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. ! 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
implicit none implicit none
integer(psb_ipk_), intent(in) :: locx(:,:) 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 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 :: 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_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
@ -127,7 +127,7 @@ subroutine psb_igatherm(globx, locx, desc_a, info, iroot)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
call psb_realloc(m,k,globx,info) call psb_realloc(m,k,globx,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_dealloc_ 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) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psb_igatherm 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. ! 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
@ -292,14 +293,21 @@ subroutine psb_igatherv(globx, locx, desc_a, info, iroot)
call psb_errpush(info,name) call psb_errpush(info,name)
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()
call psb_loc_to_glob(i,idx,desc_a,info) call psb_loc_to_glob(i,idx,desc_a,info)
globx(idx) = locx(i) globx(idx) = locx(i)
end do end do
! adjust overlapped elements ! adjust overlapped elements
do i=1, size(desc_a%ovrlap_elem,1) do i=1, size(desc_a%ovrlap_elem,1)
if (me /= desc_a%ovrlap_elem(i,3)) then 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 globx(idx) = izero
end if end if
end do end do
call psb_sum(ictxt,globx(1:m),root=root) call psb_sum(ictxt,globx(1:m),root=root)
call psb_erractionrestore(err_act) 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) 9999 call psb_error_handler(ictxt,err_act)
return return
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)
@ -429,6 +438,6 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psb_igather_vect end subroutine psb_igather_vect

120
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
@ -59,19 +58,19 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
use psi_mod use psi_mod
implicit none implicit none
integer(psb_ipk_), intent(inout), target :: x(:,:) integer(psb_ipk_), intent(inout), target :: x(:,:)
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
@ -103,7 +102,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
maxk=size(x,2)-ijx+1 maxk=size(x,2)-ijx+1
if(present(ik)) then if(present(ik)) then
if(ik > maxk) then if(ik > maxk) then
k=maxk k=maxk
@ -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
@ -279,19 +275,19 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
use psi_mod use psi_mod
implicit none implicit none
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), intent(inout) :: x(:)
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
logical :: aliw logical :: aliw
@ -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

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

@ -29,11 +29,12 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
!
! File: psb_iovrl.f90 ! File: psb_iovrl.f90
! !
! Subroutine: psb_iovrlm ! Subroutine: psb_iovrlm
! This subroutine performs the exchange of the overlap elements in a ! 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: ! Arguments:
! x(:,:) - integer The local part of the dense matrix. ! x(:,:) - integer The local part of the dense matrix.
@ -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
@ -69,19 +70,19 @@ subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
implicit none implicit none
integer(psb_ipk_), intent(inout), target :: x(:,:) integer(psb_ipk_), intent(inout), target :: x(:,:)
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_), optional, target, intent(inout) :: work(:) integer(psb_ipk_), optional, target, intent(inout) :: work(:)
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
name='psb_iovrlm' name='psb_iovrlm'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
@ -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
@ -230,18 +231,18 @@ end subroutine psb_iovrlm
! !
! Subroutine: psb_iovrlv ! Subroutine: psb_iovrlv
! This subroutine performs the exchange of the overlap elements in a ! 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: ! 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. ! 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
! psb_avg_ average of overlaps ! psb_avg_ average of overlaps
! mode - integer(optional). Choose the algorithm for data exchange: ! mode - integer(optional). Choose the algorithm for data exchange:
! this is chosen through bit fields. ! this is chosen through bit fields.
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 ! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
! - swap_sync = iand(flag,psb_swap_sync_) /= 0 ! - swap_sync = iand(flag,psb_swap_sync_) /= 0
@ -258,23 +259,22 @@ 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
implicit none implicit none
integer(psb_ipk_), intent(inout), target :: x(:) integer(psb_ipk_), intent(inout), target :: x(:)
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_), optional, target, intent(inout) :: work(:) 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 ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
@ -316,8 +316,7 @@ 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)
if(info /= psb_success_) then if(info /= psb_success_) then
@ -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

128
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,13 +60,14 @@ 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
name='psb_scatterm' name='psb_scatterm'
@ -87,14 +89,14 @@ 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
else else
root = -1 root = -1
end if end if
if (root == -1) then if (root == -1) then
iiroot = psb_root_ iiroot = psb_root_
endif endif
@ -178,13 +180,20 @@ 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)
if(info /= psb_success_) then else
info=psb_err_from_subroutine_ !
ch_err='Allocate' ! This is to keep debugging compilers from being upset by
call psb_errpush(info,name,a_err=ch_err) ! calling an external MPI function with an unallocated array;
goto 9999 ! the Fortran side would complain even if the MPI side does
end if ! 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,&
@ -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.
! !
@ -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,& 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(:)
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
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
name='psb_scatterv' name='psb_scatterv'
@ -314,17 +330,17 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
endif endif
if (present(iroot)) then if (present(iroot)) then
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
else else
root = -1 root = -1
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,me)
@ -345,16 +361,16 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx)
if(info /= psb_success_) then 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 if ((ilx /= 1).or.(iglobx /= 1)) then
info=psb_err_ix_n1_iy_n1_unsupported_ info=psb_err_ix_n1_iy_n1_unsupported_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
nrow = desc_a%get_local_rows() 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) 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
@ -388,9 +411,24 @@ subroutine psb_iscatterv(globx, locx, desc_a, info, iroot)
write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), & write(debug_unit,*) me,' ',trim(name),' displ:',displ(1:np), &
&' dim',all_dim(1:np), sum(all_dim) &' dim',all_dim(1:np), sum(all_dim)
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