fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 12:52:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_c_vect_mod.F90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_s_vect_mod.F90
 base/modules/psb_z_base_vect_mod.f90
 base/modules/psb_z_vect_mod.F90
 base/modules/psi_c_mod.f90
 base/modules/psi_d_mod.f90
 base/modules/psi_i_mod.f90
 base/modules/psi_s_mod.f90
 base/modules/psi_z_mod.f90

Encapsulated multivectors. Defined interfaces to swapdata & swaptran.
This commit is contained in:
Salvatore Filippone
2015-07-13 14:37:13 +00:00
parent 1917e2212a
commit 24aaaaec93
15 changed files with 926 additions and 448 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_c_base_vect_mod.f90
+56 -56
View File
@@ -1335,7 +1335,7 @@ end module psb_c_base_vect_mod
module psb_c_base_multivect_mod
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
@@ -1453,14 +1453,14 @@ module psb_c_base_multivect_mod
interface psb_c_base_multivect
module procedure constructor, size_const
end interface
end interface psb_c_base_multivect
contains
!
! Constructors.
!
!> Function constructor:
!! \brief Constructor from an array
!! \param x(:) input array to be copied
@@ -1473,8 +1473,8 @@ contains
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
!> Function constructor:
!! \brief Constructor from size
!! \param n Size of vector to be built.
@@ -1487,7 +1487,7 @@ contains
call this%asb(m,n,info)
end function size_const
!
! Build from a sample
!
@@ -1511,7 +1511,7 @@ contains
x%v(:,:) = this(:,:)
end subroutine c_base_mlv_bld_x
!
! Create with size, but no initialization
!
@@ -1531,7 +1531,7 @@ contains
call x%asb(m,n,info)
end subroutine c_base_mlv_bld_n
!> Function base_mlv_all:
!! \memberof psb_c_base_multivect_type
!! \brief Build method with size (uninitialized data) and
@@ -1546,9 +1546,9 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
end subroutine c_base_mlv_all
!> Function base_mlv_mold:
@@ -1564,7 +1564,7 @@ contains
class(psb_c_base_multivect_type), intent(in) :: x
class(psb_c_base_multivect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_c_base_multivect_type :: y, stat=info)
end subroutine c_base_mlv_mold
@@ -1643,8 +1643,8 @@ contains
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
if (info /= 0) then
@@ -1664,12 +1664,12 @@ contains
use psi_serial_mod
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=czero
end subroutine c_base_mlv_zero
!
! Assembly.
! For derived classes: after this the vector
@@ -1683,7 +1683,7 @@ contains
!! \param info return code
!!
!
subroutine c_base_mlv_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
@@ -1691,7 +1691,7 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
@@ -1714,15 +1714,15 @@ contains
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine c_base_mlv_free
!
! The base version of SYNC & friends does nothing, it's just
@@ -1737,7 +1737,7 @@ contains
subroutine c_base_mlv_sync(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
end subroutine c_base_mlv_sync
!
@@ -1749,7 +1749,7 @@ contains
subroutine c_base_mlv_set_host(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
end subroutine c_base_mlv_set_host
!
@@ -1761,7 +1761,7 @@ contains
subroutine c_base_mlv_set_dev(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
end subroutine c_base_mlv_set_dev
!
@@ -1773,7 +1773,7 @@ contains
subroutine c_base_mlv_set_sync(x)
implicit none
class(psb_c_base_multivect_type), intent(inout) :: x
end subroutine c_base_mlv_set_sync
!
@@ -1786,10 +1786,10 @@ contains
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
logical :: res
res = .false.
end function c_base_mlv_is_dev
!
!> Function base_mlv_is_host
!! \memberof psb_c_base_multivect_type
@@ -1847,7 +1847,7 @@ contains
if (allocated(x%v)) res = size(x%v,2)
end function c_base_mlv_get_ncols
!
!> Function base_mlv_get_sizeof
!! \memberof psb_c_base_multivect_type
@@ -1858,7 +1858,7 @@ contains
implicit none
class(psb_c_base_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols()
@@ -1875,7 +1875,7 @@ contains
character(len=5) :: res
res = 'BASE'
end function c_base_mlv_get_fmt
!
!
@@ -1900,7 +1900,7 @@ contains
end if
res(1:m,1:n) = x%v(1:m,1:n)
end function c_base_mlv_get_vect
!
! Reset all values
!
@@ -1913,10 +1913,10 @@ contains
subroutine c_base_mlv_set_scal(x,val)
class(psb_c_base_multivect_type), intent(inout) :: x
complex(psb_spk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine c_base_mlv_set_scal
!
@@ -1934,7 +1934,7 @@ contains
if (allocated(x%v)) then
nr = min(size(x%v,1),size(val,1))
nc = min(size(x%v,2),size(val,2))
x%v(1:nr,1:nc) = val(1:nr,1:nc)
else
x%v = val
@@ -1977,7 +1977,7 @@ contains
do j=1,nc
res(j) = cdotc(n,x%v(:,j),1,y%v(:,j),1)
end do
class default
class default
res = y%dot(n,x%v)
end select
@@ -2010,7 +2010,7 @@ contains
end do
end function c_base_mlv_dot_a
!
! AXPBY is invoked via Y, hence the structure below.
!
@@ -2044,7 +2044,7 @@ contains
select type(xx => x)
type is (psb_c_base_multivect_type)
call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info)
class default
class default
call y%axpby(m,alpha,x%v,beta,info,n=n)
end select
@@ -2078,12 +2078,12 @@ contains
else
nc = min(size(x,2),psb_size(y%v,2))
end if
call psb_geaxpby(m,nc,alpha,x,beta,y%v,info)
end subroutine c_base_mlv_axpby_a
!
! Multiple variants of two operations:
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
@@ -2109,7 +2109,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine c_base_mlv_mlt_mv
subroutine c_base_mlv_mlt_mv_v(x, y, info)
@@ -2122,7 +2122,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine c_base_mlv_mlt_mv_v
!
@@ -2145,7 +2145,7 @@ contains
do i=1, n
y%v(i,:) = y%v(i,:)*x(i)
end do
end subroutine c_base_mlv_mlt_ar1
!
@@ -2167,7 +2167,7 @@ contains
nr = min(psb_size(y%v,1), size(x,1))
nc = min(psb_size(y%v,2), size(x,2))
y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc)
end subroutine c_base_mlv_mlt_ar2
@@ -2324,7 +2324,7 @@ contains
if (allocated(x%v)) x%v = alpha*x%v
end subroutine c_base_mlv_scal
!
! Norms 1, 2 and infinity
!
@@ -2348,7 +2348,7 @@ contains
end do
end function c_base_mlv_nrm2
!
!> Function base_mlv_amax
!! \memberof psb_c_base_multivect_type
@@ -2366,7 +2366,7 @@ contains
allocate(res(nc))
do j=1,nc
res(j) = maxval(abs(x%v(1:n,j)))
end do
end do
end function c_base_mlv_amax
@@ -2406,7 +2406,7 @@ contains
x%v = abs(x%v)
call x%set_host()
end if
end subroutine c_base_mlv_absval1
subroutine c_base_mlv_absval2(x,y)
@@ -2418,10 +2418,9 @@ contains
call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info)
call y%absval()
end if
end subroutine c_base_mlv_absval2
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
@@ -2447,7 +2446,7 @@ contains
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,alpha,x%v,beta,y)
end subroutine c_base_mlv_gthab
!
! shortcut alpha=1 beta=0
@@ -2485,13 +2484,13 @@ contains
complex(psb_spk_) :: y(:)
class(psb_c_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,x%v,y)
end subroutine c_base_mlv_gthzv
@@ -2515,7 +2514,7 @@ contains
complex(psb_spk_) :: beta, x(:)
class(psb_c_base_multivect_type) :: y
integer(psb_ipk_) :: nc
if (y%is_dev()) call y%sync()
nc = psb_size(y%v,2)
call psi_sct(n,nc,idx,x,beta,y%v)
@@ -2529,9 +2528,10 @@ contains
class(psb_i_base_vect_type) :: idx
complex( psb_spk_) :: beta, x(:)
class(psb_c_base_multivect_type) :: y
call y%sct(n,idx%v(i:),x,beta)
end subroutine c_base_mlv_sctb_x
end module psb_c_base_multivect_mod
base/modules/psb_c_vect_mod.F90
+65 -37
View File
@@ -802,6 +802,8 @@ module psb_c_multivect_mod
use psb_c_base_multivect_mod
use psb_const_mod
use psb_i_vect_mod
!private
@@ -829,11 +831,13 @@ module psb_c_multivect_mod
procedure, pass(x) :: set_vect => c_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => c_vect_clone
!!$ procedure, pass(x) :: gthab => c_vect_gthab
!!$ procedure, pass(x) :: gthzv => c_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => c_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: gthab => c_vect_gthab
procedure, pass(x) :: gthzv => c_vect_gthzv
procedure, pass(x) :: gthzv_x => c_vect_gthzv_x
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => c_vect_sctb
procedure, pass(y) :: sctb_x => c_vect_sctb_x
generic, public :: sct => sctb, sctb_x
!!$ procedure, pass(x) :: dot_v => c_vect_dot_v
!!$ procedure, pass(x) :: dot_a => c_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
@@ -1129,38 +1133,62 @@ contains
end subroutine c_vect_sync
!!$ subroutine c_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: alpha, beta, y(:)
!!$ class(psb_c_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine c_vect_gthab
!!$
!!$ subroutine c_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: y(:)
!!$ class(psb_c_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine c_vect_gthzv
!!$
!!$ subroutine c_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: beta, x(:)
!!$ class(psb_c_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine c_vect_sctb
subroutine c_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_spk_) :: alpha, beta, y(:)
class(psb_c_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine c_vect_gthab
subroutine c_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_spk_) :: y(:)
class(psb_c_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine c_vect_gthzv
subroutine c_vect_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
complex(psb_spk_) :: y(:)
class(psb_c_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(i,n,idx,y)
end subroutine c_vect_gthzv_x
subroutine c_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_spk_) :: beta, x(:)
class(psb_c_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine c_vect_sctb
subroutine c_vect_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
complex(psb_spk_) :: beta, x(:)
class(psb_c_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(i,n,idx,x,beta)
end subroutine c_vect_sctb_x
subroutine c_vect_free(x, info)
use psi_serial_mod
base/modules/psb_d_base_vect_mod.f90
+56 -56
View File
@@ -1335,7 +1335,7 @@ end module psb_d_base_vect_mod
module psb_d_base_multivect_mod
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
@@ -1453,14 +1453,14 @@ module psb_d_base_multivect_mod
interface psb_d_base_multivect
module procedure constructor, size_const
end interface
end interface psb_d_base_multivect
contains
!
! Constructors.
!
!> Function constructor:
!! \brief Constructor from an array
!! \param x(:) input array to be copied
@@ -1473,8 +1473,8 @@ contains
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
!> Function constructor:
!! \brief Constructor from size
!! \param n Size of vector to be built.
@@ -1487,7 +1487,7 @@ contains
call this%asb(m,n,info)
end function size_const
!
! Build from a sample
!
@@ -1511,7 +1511,7 @@ contains
x%v(:,:) = this(:,:)
end subroutine d_base_mlv_bld_x
!
! Create with size, but no initialization
!
@@ -1531,7 +1531,7 @@ contains
call x%asb(m,n,info)
end subroutine d_base_mlv_bld_n
!> Function base_mlv_all:
!! \memberof psb_d_base_multivect_type
!! \brief Build method with size (uninitialized data) and
@@ -1546,9 +1546,9 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
end subroutine d_base_mlv_all
!> Function base_mlv_mold:
@@ -1564,7 +1564,7 @@ contains
class(psb_d_base_multivect_type), intent(in) :: x
class(psb_d_base_multivect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_d_base_multivect_type :: y, stat=info)
end subroutine d_base_mlv_mold
@@ -1643,8 +1643,8 @@ contains
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
if (info /= 0) then
@@ -1664,12 +1664,12 @@ contains
use psi_serial_mod
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=dzero
end subroutine d_base_mlv_zero
!
! Assembly.
! For derived classes: after this the vector
@@ -1683,7 +1683,7 @@ contains
!! \param info return code
!!
!
subroutine d_base_mlv_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
@@ -1691,7 +1691,7 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
@@ -1714,15 +1714,15 @@ contains
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine d_base_mlv_free
!
! The base version of SYNC & friends does nothing, it's just
@@ -1737,7 +1737,7 @@ contains
subroutine d_base_mlv_sync(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
end subroutine d_base_mlv_sync
!
@@ -1749,7 +1749,7 @@ contains
subroutine d_base_mlv_set_host(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
end subroutine d_base_mlv_set_host
!
@@ -1761,7 +1761,7 @@ contains
subroutine d_base_mlv_set_dev(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
end subroutine d_base_mlv_set_dev
!
@@ -1773,7 +1773,7 @@ contains
subroutine d_base_mlv_set_sync(x)
implicit none
class(psb_d_base_multivect_type), intent(inout) :: x
end subroutine d_base_mlv_set_sync
!
@@ -1786,10 +1786,10 @@ contains
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
logical :: res
res = .false.
end function d_base_mlv_is_dev
!
!> Function base_mlv_is_host
!! \memberof psb_d_base_multivect_type
@@ -1847,7 +1847,7 @@ contains
if (allocated(x%v)) res = size(x%v,2)
end function d_base_mlv_get_ncols
!
!> Function base_mlv_get_sizeof
!! \memberof psb_d_base_multivect_type
@@ -1858,7 +1858,7 @@ contains
implicit none
class(psb_d_base_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols()
@@ -1875,7 +1875,7 @@ contains
character(len=5) :: res
res = 'BASE'
end function d_base_mlv_get_fmt
!
!
@@ -1900,7 +1900,7 @@ contains
end if
res(1:m,1:n) = x%v(1:m,1:n)
end function d_base_mlv_get_vect
!
! Reset all values
!
@@ -1913,10 +1913,10 @@ contains
subroutine d_base_mlv_set_scal(x,val)
class(psb_d_base_multivect_type), intent(inout) :: x
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine d_base_mlv_set_scal
!
@@ -1934,7 +1934,7 @@ contains
if (allocated(x%v)) then
nr = min(size(x%v,1),size(val,1))
nc = min(size(x%v,2),size(val,2))
x%v(1:nr,1:nc) = val(1:nr,1:nc)
else
x%v = val
@@ -1977,7 +1977,7 @@ contains
do j=1,nc
res(j) = ddot(n,x%v(:,j),1,y%v(:,j),1)
end do
class default
class default
res = y%dot(n,x%v)
end select
@@ -2010,7 +2010,7 @@ contains
end do
end function d_base_mlv_dot_a
!
! AXPBY is invoked via Y, hence the structure below.
!
@@ -2044,7 +2044,7 @@ contains
select type(xx => x)
type is (psb_d_base_multivect_type)
call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info)
class default
class default
call y%axpby(m,alpha,x%v,beta,info,n=n)
end select
@@ -2078,12 +2078,12 @@ contains
else
nc = min(size(x,2),psb_size(y%v,2))
end if
call psb_geaxpby(m,nc,alpha,x,beta,y%v,info)
end subroutine d_base_mlv_axpby_a
!
! Multiple variants of two operations:
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
@@ -2109,7 +2109,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine d_base_mlv_mlt_mv
subroutine d_base_mlv_mlt_mv_v(x, y, info)
@@ -2122,7 +2122,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine d_base_mlv_mlt_mv_v
!
@@ -2145,7 +2145,7 @@ contains
do i=1, n
y%v(i,:) = y%v(i,:)*x(i)
end do
end subroutine d_base_mlv_mlt_ar1
!
@@ -2167,7 +2167,7 @@ contains
nr = min(psb_size(y%v,1), size(x,1))
nc = min(psb_size(y%v,2), size(x,2))
y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc)
end subroutine d_base_mlv_mlt_ar2
@@ -2324,7 +2324,7 @@ contains
if (allocated(x%v)) x%v = alpha*x%v
end subroutine d_base_mlv_scal
!
! Norms 1, 2 and infinity
!
@@ -2348,7 +2348,7 @@ contains
end do
end function d_base_mlv_nrm2
!
!> Function base_mlv_amax
!! \memberof psb_d_base_multivect_type
@@ -2366,7 +2366,7 @@ contains
allocate(res(nc))
do j=1,nc
res(j) = maxval(abs(x%v(1:n,j)))
end do
end do
end function d_base_mlv_amax
@@ -2406,7 +2406,7 @@ contains
x%v = abs(x%v)
call x%set_host()
end if
end subroutine d_base_mlv_absval1
subroutine d_base_mlv_absval2(x,y)
@@ -2418,10 +2418,9 @@ contains
call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info)
call y%absval()
end if
end subroutine d_base_mlv_absval2
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
@@ -2447,7 +2446,7 @@ contains
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,alpha,x%v,beta,y)
end subroutine d_base_mlv_gthab
!
! shortcut alpha=1 beta=0
@@ -2485,13 +2484,13 @@ contains
real(psb_dpk_) :: y(:)
class(psb_d_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,x%v,y)
end subroutine d_base_mlv_gthzv
@@ -2515,7 +2514,7 @@ contains
real(psb_dpk_) :: beta, x(:)
class(psb_d_base_multivect_type) :: y
integer(psb_ipk_) :: nc
if (y%is_dev()) call y%sync()
nc = psb_size(y%v,2)
call psi_sct(n,nc,idx,x,beta,y%v)
@@ -2529,9 +2528,10 @@ contains
class(psb_i_base_vect_type) :: idx
real( psb_dpk_) :: beta, x(:)
class(psb_d_base_multivect_type) :: y
call y%sct(n,idx%v(i:),x,beta)
end subroutine d_base_mlv_sctb_x
end module psb_d_base_multivect_mod
base/modules/psb_d_vect_mod.F90
+65 -37
View File
@@ -802,6 +802,8 @@ module psb_d_multivect_mod
use psb_d_base_multivect_mod
use psb_const_mod
use psb_i_vect_mod
!private
@@ -829,11 +831,13 @@ module psb_d_multivect_mod
procedure, pass(x) :: set_vect => d_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => d_vect_clone
!!$ procedure, pass(x) :: gthab => d_vect_gthab
!!$ procedure, pass(x) :: gthzv => d_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => d_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: gthab => d_vect_gthab
procedure, pass(x) :: gthzv => d_vect_gthzv
procedure, pass(x) :: gthzv_x => d_vect_gthzv_x
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => d_vect_sctb
procedure, pass(y) :: sctb_x => d_vect_sctb_x
generic, public :: sct => sctb, sctb_x
!!$ procedure, pass(x) :: dot_v => d_vect_dot_v
!!$ procedure, pass(x) :: dot_a => d_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
@@ -1129,38 +1133,62 @@ contains
end subroutine d_vect_sync
!!$ subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: alpha, beta, y(:)
!!$ class(psb_d_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine d_vect_gthab
!!$
!!$ subroutine d_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: y(:)
!!$ class(psb_d_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine d_vect_gthzv
!!$
!!$ subroutine d_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: beta, x(:)
!!$ class(psb_d_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine d_vect_sctb
subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_dpk_) :: alpha, beta, y(:)
class(psb_d_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine d_vect_gthab
subroutine d_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_dpk_) :: y(:)
class(psb_d_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine d_vect_gthzv
subroutine d_vect_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
real(psb_dpk_) :: y(:)
class(psb_d_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(i,n,idx,y)
end subroutine d_vect_gthzv_x
subroutine d_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_dpk_) :: beta, x(:)
class(psb_d_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine d_vect_sctb
subroutine d_vect_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_dpk_) :: beta, x(:)
class(psb_d_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(i,n,idx,x,beta)
end subroutine d_vect_sctb_x
subroutine d_vect_free(x, info)
use psi_serial_mod
base/modules/psb_i_base_vect_mod.f90
+157 -34
View File
@@ -876,7 +876,7 @@ end module psb_i_base_vect_mod
module psb_i_base_multivect_mod
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
@@ -946,18 +946,29 @@ module psb_i_base_multivect_mod
procedure, pass(x) :: set_vect => i_base_mlv_set_vect
generic, public :: set => set_vect, set_scal
!!$ !
!!$ ! Gather/scatter. These are needed for MPI interfacing.
!!$ ! May have to be reworked.
!!$ !
procedure, pass(x) :: gthab => i_base_mlv_gthab
procedure, pass(x) :: gthzv => i_base_mlv_gthzv
procedure, pass(x) :: gthzv_x => i_base_mlv_gthzv_x
generic, public :: gth => gthab, gthzv, gthzv_x
procedure, pass(y) :: sctb => i_base_mlv_sctb
procedure, pass(y) :: sctb_x => i_base_mlv_sctb_x
generic, public :: sct => sctb, sctb_x
end type psb_i_base_multivect_type
interface psb_i_base_multivect
module procedure constructor, size_const
end interface
end interface psb_i_base_multivect
contains
!
! Constructors.
!
!> Function constructor:
!! \brief Constructor from an array
!! \param x(:) input array to be copied
@@ -970,8 +981,8 @@ contains
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
!> Function constructor:
!! \brief Constructor from size
!! \param n Size of vector to be built.
@@ -984,7 +995,7 @@ contains
call this%asb(m,n,info)
end function size_const
!
! Build from a sample
!
@@ -1008,7 +1019,7 @@ contains
x%v(:,:) = this(:,:)
end subroutine i_base_mlv_bld_x
!
! Create with size, but no initialization
!
@@ -1028,7 +1039,7 @@ contains
call x%asb(m,n,info)
end subroutine i_base_mlv_bld_n
!> Function base_mlv_all:
!! \memberof psb_i_base_multivect_type
!! \brief Build method with size (uninitialized data) and
@@ -1043,9 +1054,9 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
end subroutine i_base_mlv_all
!> Function base_mlv_mold:
@@ -1061,7 +1072,7 @@ contains
class(psb_i_base_multivect_type), intent(in) :: x
class(psb_i_base_multivect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_i_base_multivect_type :: y, stat=info)
end subroutine i_base_mlv_mold
@@ -1140,8 +1151,8 @@ contains
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
if (info /= 0) then
@@ -1161,12 +1172,12 @@ contains
use psi_serial_mod
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=izero
end subroutine i_base_mlv_zero
!
! Assembly.
! For derived classes: after this the vector
@@ -1180,7 +1191,7 @@ contains
!! \param info return code
!!
!
subroutine i_base_mlv_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
@@ -1188,7 +1199,7 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
@@ -1211,15 +1222,15 @@ contains
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine i_base_mlv_free
!
! The base version of SYNC & friends does nothing, it's just
@@ -1234,7 +1245,7 @@ contains
subroutine i_base_mlv_sync(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
end subroutine i_base_mlv_sync
!
@@ -1246,7 +1257,7 @@ contains
subroutine i_base_mlv_set_host(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
end subroutine i_base_mlv_set_host
!
@@ -1258,7 +1269,7 @@ contains
subroutine i_base_mlv_set_dev(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
end subroutine i_base_mlv_set_dev
!
@@ -1270,7 +1281,7 @@ contains
subroutine i_base_mlv_set_sync(x)
implicit none
class(psb_i_base_multivect_type), intent(inout) :: x
end subroutine i_base_mlv_set_sync
!
@@ -1283,10 +1294,10 @@ contains
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
logical :: res
res = .false.
end function i_base_mlv_is_dev
!
!> Function base_mlv_is_host
!! \memberof psb_i_base_multivect_type
@@ -1344,7 +1355,7 @@ contains
if (allocated(x%v)) res = size(x%v,2)
end function i_base_mlv_get_ncols
!
!> Function base_mlv_get_sizeof
!! \memberof psb_i_base_multivect_type
@@ -1355,7 +1366,7 @@ contains
implicit none
class(psb_i_base_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols()
@@ -1372,7 +1383,7 @@ contains
character(len=5) :: res
res = 'BASE'
end function i_base_mlv_get_fmt
!
!
@@ -1397,7 +1408,7 @@ contains
end if
res(1:m,1:n) = x%v(1:m,1:n)
end function i_base_mlv_get_vect
!
! Reset all values
!
@@ -1410,10 +1421,10 @@ contains
subroutine i_base_mlv_set_scal(x,val)
class(psb_i_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine i_base_mlv_set_scal
!
@@ -1431,7 +1442,7 @@ contains
if (allocated(x%v)) then
nr = min(size(x%v,1),size(val,1))
nc = min(size(x%v,2),size(val,2))
x%v(1:nr,1:nc) = val(1:nr,1:nc)
else
x%v = val
@@ -1439,5 +1450,117 @@ contains
end subroutine i_base_mlv_set_vect
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
!
!> Function base_mlv_gthab
!! \memberof psb_i_base_multivect_type
!! \brief gather into an array
!! Y = beta * Y + alpha * X(IDX(:))
!! \param n how many entries to consider
!! \param idx(:) indices
!! \param alpha
!! \param beta
subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: alpha, beta, y(:)
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,alpha,x%v,beta,y)
end subroutine i_base_mlv_gthab
!
! shortcut alpha=1 beta=0
!
!> Function base_mlv_gthzv
!! \memberof psb_i_base_multivect_type
!! \brief gather into an array special alpha=1 beta=0
!! Y = X(IDX(:))
!! \param n how many entries to consider
!! \param idx(:) indices
subroutine i_base_mlv_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: y(:)
class(psb_i_base_multivect_type) :: x
if (x%is_dev()) call x%sync()
call x%gth(n,idx%v(i:),y)
end subroutine i_base_mlv_gthzv_x
!
! shortcut alpha=1 beta=0
!
!> Function base_mlv_gthzv
!! \memberof psb_i_base_multivect_type
!! \brief gather into an array special alpha=1 beta=0
!! Y = X(IDX(:))
!! \param n how many entries to consider
!! \param idx(:) indices
subroutine i_base_mlv_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: y(:)
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,x%v,y)
end subroutine i_base_mlv_gthzv
!
! Scatter:
! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
!
!
!> Function base_mlv_sctb
!! \memberof psb_i_base_multivect_type
!! \brief scatter into a class(base_mlv_vect)
!! Y(IDX(:)) = beta * Y(IDX(:)) + X(:)
!! \param n how many entries to consider
!! \param idx(:) indices
!! \param beta
!! \param x(:)
subroutine i_base_mlv_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: beta, x(:)
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: nc
if (y%is_dev()) call y%sync()
nc = psb_size(y%v,2)
call psi_sct(n,nc,idx,x,beta,y%v)
call y%set_host()
end subroutine i_base_mlv_sctb
subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
integer( psb_ipk_) :: beta, x(:)
class(psb_i_base_multivect_type) :: y
call y%sct(n,idx%v(i:),x,beta)
end subroutine i_base_mlv_sctb_x
end module psb_i_base_multivect_mod
base/modules/psb_i_vect_mod.F90
+65 -37
View File
@@ -549,6 +549,8 @@ module psb_i_multivect_mod
use psb_i_base_multivect_mod
use psb_const_mod
use psb_i_vect_mod
!private
@@ -576,11 +578,13 @@ module psb_i_multivect_mod
procedure, pass(x) :: set_vect => i_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => i_vect_clone
!!$ procedure, pass(x) :: gthab => i_vect_gthab
!!$ procedure, pass(x) :: gthzv => i_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => i_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv
procedure, pass(x) :: gthzv_x => i_vect_gthzv_x
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => i_vect_sctb
procedure, pass(y) :: sctb_x => i_vect_sctb_x
generic, public :: sct => sctb, sctb_x
end type psb_i_multivect_type
public :: psb_i_multivect, psb_i_multivect_type,&
@@ -858,38 +862,62 @@ contains
end subroutine i_vect_sync
!!$ subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: alpha, beta, y(:)
!!$ class(psb_i_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine i_vect_gthab
!!$
!!$ subroutine i_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: y(:)
!!$ class(psb_i_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine i_vect_gthzv
!!$
!!$ subroutine i_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: beta, x(:)
!!$ class(psb_i_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine i_vect_sctb
subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: alpha, beta, y(:)
class(psb_i_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine i_vect_gthab
subroutine i_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: y(:)
class(psb_i_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine i_vect_gthzv
subroutine i_vect_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: y(:)
class(psb_i_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(i,n,idx,y)
end subroutine i_vect_gthzv_x
subroutine i_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: beta, x(:)
class(psb_i_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine i_vect_sctb
subroutine i_vect_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: beta, x(:)
class(psb_i_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(i,n,idx,x,beta)
end subroutine i_vect_sctb_x
subroutine i_vect_free(x, info)
use psi_serial_mod
base/modules/psb_s_base_vect_mod.f90
+56 -56
View File
@@ -1335,7 +1335,7 @@ end module psb_s_base_vect_mod
module psb_s_base_multivect_mod
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
@@ -1453,14 +1453,14 @@ module psb_s_base_multivect_mod
interface psb_s_base_multivect
module procedure constructor, size_const
end interface
end interface psb_s_base_multivect
contains
!
! Constructors.
!
!> Function constructor:
!! \brief Constructor from an array
!! \param x(:) input array to be copied
@@ -1473,8 +1473,8 @@ contains
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
!> Function constructor:
!! \brief Constructor from size
!! \param n Size of vector to be built.
@@ -1487,7 +1487,7 @@ contains
call this%asb(m,n,info)
end function size_const
!
! Build from a sample
!
@@ -1511,7 +1511,7 @@ contains
x%v(:,:) = this(:,:)
end subroutine s_base_mlv_bld_x
!
! Create with size, but no initialization
!
@@ -1531,7 +1531,7 @@ contains
call x%asb(m,n,info)
end subroutine s_base_mlv_bld_n
!> Function base_mlv_all:
!! \memberof psb_s_base_multivect_type
!! \brief Build method with size (uninitialized data) and
@@ -1546,9 +1546,9 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
end subroutine s_base_mlv_all
!> Function base_mlv_mold:
@@ -1564,7 +1564,7 @@ contains
class(psb_s_base_multivect_type), intent(in) :: x
class(psb_s_base_multivect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_s_base_multivect_type :: y, stat=info)
end subroutine s_base_mlv_mold
@@ -1643,8 +1643,8 @@ contains
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
if (info /= 0) then
@@ -1664,12 +1664,12 @@ contains
use psi_serial_mod
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=szero
end subroutine s_base_mlv_zero
!
! Assembly.
! For derived classes: after this the vector
@@ -1683,7 +1683,7 @@ contains
!! \param info return code
!!
!
subroutine s_base_mlv_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
@@ -1691,7 +1691,7 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
@@ -1714,15 +1714,15 @@ contains
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine s_base_mlv_free
!
! The base version of SYNC & friends does nothing, it's just
@@ -1737,7 +1737,7 @@ contains
subroutine s_base_mlv_sync(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
end subroutine s_base_mlv_sync
!
@@ -1749,7 +1749,7 @@ contains
subroutine s_base_mlv_set_host(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
end subroutine s_base_mlv_set_host
!
@@ -1761,7 +1761,7 @@ contains
subroutine s_base_mlv_set_dev(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
end subroutine s_base_mlv_set_dev
!
@@ -1773,7 +1773,7 @@ contains
subroutine s_base_mlv_set_sync(x)
implicit none
class(psb_s_base_multivect_type), intent(inout) :: x
end subroutine s_base_mlv_set_sync
!
@@ -1786,10 +1786,10 @@ contains
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
logical :: res
res = .false.
end function s_base_mlv_is_dev
!
!> Function base_mlv_is_host
!! \memberof psb_s_base_multivect_type
@@ -1847,7 +1847,7 @@ contains
if (allocated(x%v)) res = size(x%v,2)
end function s_base_mlv_get_ncols
!
!> Function base_mlv_get_sizeof
!! \memberof psb_s_base_multivect_type
@@ -1858,7 +1858,7 @@ contains
implicit none
class(psb_s_base_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols()
@@ -1875,7 +1875,7 @@ contains
character(len=5) :: res
res = 'BASE'
end function s_base_mlv_get_fmt
!
!
@@ -1900,7 +1900,7 @@ contains
end if
res(1:m,1:n) = x%v(1:m,1:n)
end function s_base_mlv_get_vect
!
! Reset all values
!
@@ -1913,10 +1913,10 @@ contains
subroutine s_base_mlv_set_scal(x,val)
class(psb_s_base_multivect_type), intent(inout) :: x
real(psb_spk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine s_base_mlv_set_scal
!
@@ -1934,7 +1934,7 @@ contains
if (allocated(x%v)) then
nr = min(size(x%v,1),size(val,1))
nc = min(size(x%v,2),size(val,2))
x%v(1:nr,1:nc) = val(1:nr,1:nc)
else
x%v = val
@@ -1977,7 +1977,7 @@ contains
do j=1,nc
res(j) = sdot(n,x%v(:,j),1,y%v(:,j),1)
end do
class default
class default
res = y%dot(n,x%v)
end select
@@ -2010,7 +2010,7 @@ contains
end do
end function s_base_mlv_dot_a
!
! AXPBY is invoked via Y, hence the structure below.
!
@@ -2044,7 +2044,7 @@ contains
select type(xx => x)
type is (psb_s_base_multivect_type)
call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info)
class default
class default
call y%axpby(m,alpha,x%v,beta,info,n=n)
end select
@@ -2078,12 +2078,12 @@ contains
else
nc = min(size(x,2),psb_size(y%v,2))
end if
call psb_geaxpby(m,nc,alpha,x,beta,y%v,info)
end subroutine s_base_mlv_axpby_a
!
! Multiple variants of two operations:
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
@@ -2109,7 +2109,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine s_base_mlv_mlt_mv
subroutine s_base_mlv_mlt_mv_v(x, y, info)
@@ -2122,7 +2122,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine s_base_mlv_mlt_mv_v
!
@@ -2145,7 +2145,7 @@ contains
do i=1, n
y%v(i,:) = y%v(i,:)*x(i)
end do
end subroutine s_base_mlv_mlt_ar1
!
@@ -2167,7 +2167,7 @@ contains
nr = min(psb_size(y%v,1), size(x,1))
nc = min(psb_size(y%v,2), size(x,2))
y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc)
end subroutine s_base_mlv_mlt_ar2
@@ -2324,7 +2324,7 @@ contains
if (allocated(x%v)) x%v = alpha*x%v
end subroutine s_base_mlv_scal
!
! Norms 1, 2 and infinity
!
@@ -2348,7 +2348,7 @@ contains
end do
end function s_base_mlv_nrm2
!
!> Function base_mlv_amax
!! \memberof psb_s_base_multivect_type
@@ -2366,7 +2366,7 @@ contains
allocate(res(nc))
do j=1,nc
res(j) = maxval(abs(x%v(1:n,j)))
end do
end do
end function s_base_mlv_amax
@@ -2406,7 +2406,7 @@ contains
x%v = abs(x%v)
call x%set_host()
end if
end subroutine s_base_mlv_absval1
subroutine s_base_mlv_absval2(x,y)
@@ -2418,10 +2418,9 @@ contains
call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info)
call y%absval()
end if
end subroutine s_base_mlv_absval2
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
@@ -2447,7 +2446,7 @@ contains
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,alpha,x%v,beta,y)
end subroutine s_base_mlv_gthab
!
! shortcut alpha=1 beta=0
@@ -2485,13 +2484,13 @@ contains
real(psb_spk_) :: y(:)
class(psb_s_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,x%v,y)
end subroutine s_base_mlv_gthzv
@@ -2515,7 +2514,7 @@ contains
real(psb_spk_) :: beta, x(:)
class(psb_s_base_multivect_type) :: y
integer(psb_ipk_) :: nc
if (y%is_dev()) call y%sync()
nc = psb_size(y%v,2)
call psi_sct(n,nc,idx,x,beta,y%v)
@@ -2529,9 +2528,10 @@ contains
class(psb_i_base_vect_type) :: idx
real( psb_spk_) :: beta, x(:)
class(psb_s_base_multivect_type) :: y
call y%sct(n,idx%v(i:),x,beta)
end subroutine s_base_mlv_sctb_x
end module psb_s_base_multivect_mod
base/modules/psb_s_vect_mod.F90
+65 -37
View File
@@ -802,6 +802,8 @@ module psb_s_multivect_mod
use psb_s_base_multivect_mod
use psb_const_mod
use psb_i_vect_mod
!private
@@ -829,11 +831,13 @@ module psb_s_multivect_mod
procedure, pass(x) :: set_vect => s_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => s_vect_clone
!!$ procedure, pass(x) :: gthab => s_vect_gthab
!!$ procedure, pass(x) :: gthzv => s_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => s_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: gthab => s_vect_gthab
procedure, pass(x) :: gthzv => s_vect_gthzv
procedure, pass(x) :: gthzv_x => s_vect_gthzv_x
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => s_vect_sctb
procedure, pass(y) :: sctb_x => s_vect_sctb_x
generic, public :: sct => sctb, sctb_x
!!$ procedure, pass(x) :: dot_v => s_vect_dot_v
!!$ procedure, pass(x) :: dot_a => s_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
@@ -1129,38 +1133,62 @@ contains
end subroutine s_vect_sync
!!$ subroutine s_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: alpha, beta, y(:)
!!$ class(psb_s_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine s_vect_gthab
!!$
!!$ subroutine s_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: y(:)
!!$ class(psb_s_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine s_vect_gthzv
!!$
!!$ subroutine s_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: beta, x(:)
!!$ class(psb_s_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine s_vect_sctb
subroutine s_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_spk_) :: alpha, beta, y(:)
class(psb_s_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine s_vect_gthab
subroutine s_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_spk_) :: y(:)
class(psb_s_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine s_vect_gthzv
subroutine s_vect_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
real(psb_spk_) :: y(:)
class(psb_s_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(i,n,idx,y)
end subroutine s_vect_gthzv_x
subroutine s_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
real(psb_spk_) :: beta, x(:)
class(psb_s_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine s_vect_sctb
subroutine s_vect_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_spk_) :: beta, x(:)
class(psb_s_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(i,n,idx,x,beta)
end subroutine s_vect_sctb_x
subroutine s_vect_free(x, info)
use psi_serial_mod
base/modules/psb_z_base_vect_mod.f90
+56 -56
View File
@@ -1335,7 +1335,7 @@ end module psb_z_base_vect_mod
module psb_z_base_multivect_mod
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
@@ -1453,14 +1453,14 @@ module psb_z_base_multivect_mod
interface psb_z_base_multivect
module procedure constructor, size_const
end interface
end interface psb_z_base_multivect
contains
!
! Constructors.
!
!> Function constructor:
!! \brief Constructor from an array
!! \param x(:) input array to be copied
@@ -1473,8 +1473,8 @@ contains
this%v = x
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
!> Function constructor:
!! \brief Constructor from size
!! \param n Size of vector to be built.
@@ -1487,7 +1487,7 @@ contains
call this%asb(m,n,info)
end function size_const
!
! Build from a sample
!
@@ -1511,7 +1511,7 @@ contains
x%v(:,:) = this(:,:)
end subroutine z_base_mlv_bld_x
!
! Create with size, but no initialization
!
@@ -1531,7 +1531,7 @@ contains
call x%asb(m,n,info)
end subroutine z_base_mlv_bld_n
!> Function base_mlv_all:
!! \memberof psb_z_base_multivect_type
!! \brief Build method with size (uninitialized data) and
@@ -1546,9 +1546,9 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_base_multivect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(m,n,x%v,info)
end subroutine z_base_mlv_all
!> Function base_mlv_mold:
@@ -1564,7 +1564,7 @@ contains
class(psb_z_base_multivect_type), intent(in) :: x
class(psb_z_base_multivect_type), intent(out), allocatable :: y
integer(psb_ipk_), intent(out) :: info
allocate(psb_z_base_multivect_type :: y, stat=info)
end subroutine z_base_mlv_mold
@@ -1643,8 +1643,8 @@ contains
case default
info = 321
! !$ call psb_errpush(info,name)
! !$ goto 9999
! !$ call psb_errpush(info,name)
! !$ goto 9999
end select
end if
if (info /= 0) then
@@ -1664,12 +1664,12 @@ contains
use psi_serial_mod
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
if (allocated(x%v)) x%v=zzero
end subroutine z_base_mlv_zero
!
! Assembly.
! For derived classes: after this the vector
@@ -1683,7 +1683,7 @@ contains
!! \param info return code
!!
!
subroutine z_base_mlv_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
@@ -1691,7 +1691,7 @@ contains
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if ((x%get_nrows() < m).or.(x%get_ncols()<n)) &
& call psb_realloc(m,n,x%v,info)
if (info /= 0) &
@@ -1714,15 +1714,15 @@ contains
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine z_base_mlv_free
!
! The base version of SYNC & friends does nothing, it's just
@@ -1737,7 +1737,7 @@ contains
subroutine z_base_mlv_sync(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
end subroutine z_base_mlv_sync
!
@@ -1749,7 +1749,7 @@ contains
subroutine z_base_mlv_set_host(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
end subroutine z_base_mlv_set_host
!
@@ -1761,7 +1761,7 @@ contains
subroutine z_base_mlv_set_dev(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
end subroutine z_base_mlv_set_dev
!
@@ -1773,7 +1773,7 @@ contains
subroutine z_base_mlv_set_sync(x)
implicit none
class(psb_z_base_multivect_type), intent(inout) :: x
end subroutine z_base_mlv_set_sync
!
@@ -1786,10 +1786,10 @@ contains
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
logical :: res
res = .false.
end function z_base_mlv_is_dev
!
!> Function base_mlv_is_host
!! \memberof psb_z_base_multivect_type
@@ -1847,7 +1847,7 @@ contains
if (allocated(x%v)) res = size(x%v,2)
end function z_base_mlv_get_ncols
!
!> Function base_mlv_get_sizeof
!! \memberof psb_z_base_multivect_type
@@ -1858,7 +1858,7 @@ contains
implicit none
class(psb_z_base_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols()
@@ -1875,7 +1875,7 @@ contains
character(len=5) :: res
res = 'BASE'
end function z_base_mlv_get_fmt
!
!
@@ -1900,7 +1900,7 @@ contains
end if
res(1:m,1:n) = x%v(1:m,1:n)
end function z_base_mlv_get_vect
!
! Reset all values
!
@@ -1913,10 +1913,10 @@ contains
subroutine z_base_mlv_set_scal(x,val)
class(psb_z_base_multivect_type), intent(inout) :: x
complex(psb_dpk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine z_base_mlv_set_scal
!
@@ -1934,7 +1934,7 @@ contains
if (allocated(x%v)) then
nr = min(size(x%v,1),size(val,1))
nc = min(size(x%v,2),size(val,2))
x%v(1:nr,1:nc) = val(1:nr,1:nc)
else
x%v = val
@@ -1977,7 +1977,7 @@ contains
do j=1,nc
res(j) = zdotc(n,x%v(:,j),1,y%v(:,j),1)
end do
class default
class default
res = y%dot(n,x%v)
end select
@@ -2010,7 +2010,7 @@ contains
end do
end function z_base_mlv_dot_a
!
! AXPBY is invoked via Y, hence the structure below.
!
@@ -2044,7 +2044,7 @@ contains
select type(xx => x)
type is (psb_z_base_multivect_type)
call psb_geaxpby(m,nc,alpha,x%v,beta,y%v,info)
class default
class default
call y%axpby(m,alpha,x%v,beta,info,n=n)
end select
@@ -2078,12 +2078,12 @@ contains
else
nc = min(size(x,2),psb_size(y%v,2))
end if
call psb_geaxpby(m,nc,alpha,x,beta,y%v,info)
end subroutine z_base_mlv_axpby_a
!
! Multiple variants of two operations:
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
@@ -2109,7 +2109,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine z_base_mlv_mlt_mv
subroutine z_base_mlv_mlt_mv_v(x, y, info)
@@ -2122,7 +2122,7 @@ contains
info = 0
if (x%is_dev()) call x%sync()
call y%mlt(x%v,info)
end subroutine z_base_mlv_mlt_mv_v
!
@@ -2145,7 +2145,7 @@ contains
do i=1, n
y%v(i,:) = y%v(i,:)*x(i)
end do
end subroutine z_base_mlv_mlt_ar1
!
@@ -2167,7 +2167,7 @@ contains
nr = min(psb_size(y%v,1), size(x,1))
nc = min(psb_size(y%v,2), size(x,2))
y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc)
end subroutine z_base_mlv_mlt_ar2
@@ -2324,7 +2324,7 @@ contains
if (allocated(x%v)) x%v = alpha*x%v
end subroutine z_base_mlv_scal
!
! Norms 1, 2 and infinity
!
@@ -2348,7 +2348,7 @@ contains
end do
end function z_base_mlv_nrm2
!
!> Function base_mlv_amax
!! \memberof psb_z_base_multivect_type
@@ -2366,7 +2366,7 @@ contains
allocate(res(nc))
do j=1,nc
res(j) = maxval(abs(x%v(1:n,j)))
end do
end do
end function z_base_mlv_amax
@@ -2406,7 +2406,7 @@ contains
x%v = abs(x%v)
call x%set_host()
end if
end subroutine z_base_mlv_absval1
subroutine z_base_mlv_absval2(x,y)
@@ -2418,10 +2418,9 @@ contains
call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info)
call y%absval()
end if
end subroutine z_base_mlv_absval2
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
@@ -2447,7 +2446,7 @@ contains
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,alpha,x%v,beta,y)
end subroutine z_base_mlv_gthab
!
! shortcut alpha=1 beta=0
@@ -2485,13 +2484,13 @@ contains
complex(psb_dpk_) :: y(:)
class(psb_z_base_multivect_type) :: x
integer(psb_ipk_) :: nc
if (x%is_dev()) call x%sync()
if (.not.allocated(x%v)) then
return
end if
nc = psb_size(x%v,2)
call psi_gth(n,nc,idx,x%v,y)
end subroutine z_base_mlv_gthzv
@@ -2515,7 +2514,7 @@ contains
complex(psb_dpk_) :: beta, x(:)
class(psb_z_base_multivect_type) :: y
integer(psb_ipk_) :: nc
if (y%is_dev()) call y%sync()
nc = psb_size(y%v,2)
call psi_sct(n,nc,idx,x,beta,y%v)
@@ -2529,9 +2528,10 @@ contains
class(psb_i_base_vect_type) :: idx
complex( psb_dpk_) :: beta, x(:)
class(psb_z_base_multivect_type) :: y
call y%sct(n,idx%v(i:),x,beta)
end subroutine z_base_mlv_sctb_x
end module psb_z_base_multivect_mod
base/modules/psb_z_vect_mod.F90
+65 -37
View File
@@ -802,6 +802,8 @@ module psb_z_multivect_mod
use psb_z_base_multivect_mod
use psb_const_mod
use psb_i_vect_mod
!private
@@ -829,11 +831,13 @@ module psb_z_multivect_mod
procedure, pass(x) :: set_vect => z_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => z_vect_clone
!!$ procedure, pass(x) :: gthab => z_vect_gthab
!!$ procedure, pass(x) :: gthzv => z_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => z_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: gthab => z_vect_gthab
procedure, pass(x) :: gthzv => z_vect_gthzv
procedure, pass(x) :: gthzv_x => z_vect_gthzv_x
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => z_vect_sctb
procedure, pass(y) :: sctb_x => z_vect_sctb_x
generic, public :: sct => sctb, sctb_x
!!$ procedure, pass(x) :: dot_v => z_vect_dot_v
!!$ procedure, pass(x) :: dot_a => z_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
@@ -1129,38 +1133,62 @@ contains
end subroutine z_vect_sync
!!$ subroutine z_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: alpha, beta, y(:)
!!$ class(psb_z_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine z_vect_gthab
!!$
!!$ subroutine z_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: y(:)
!!$ class(psb_z_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine z_vect_gthzv
!!$
!!$ subroutine z_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: beta, x(:)
!!$ class(psb_z_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine z_vect_sctb
subroutine z_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_dpk_) :: alpha, beta, y(:)
class(psb_z_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine z_vect_gthab
subroutine z_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_dpk_) :: y(:)
class(psb_z_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine z_vect_gthzv
subroutine z_vect_gthzv_x(i,n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: i,n
class(psb_i_base_vect_type) :: idx
complex(psb_dpk_) :: y(:)
class(psb_z_multivect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(i,n,idx,y)
end subroutine z_vect_gthzv_x
subroutine z_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
complex(psb_dpk_) :: beta, x(:)
class(psb_z_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine z_vect_sctb
subroutine z_vect_sctb_x(i,n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
complex(psb_dpk_) :: beta, x(:)
class(psb_z_multivect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(i,n,idx,x,beta)
end subroutine z_vect_sctb_x
subroutine z_vect_free(x, info)
use psi_serial_mod
base/modules/psi_c_mod.f90
+44 -1
View File
@@ -31,7 +31,8 @@
!!$
module psi_c_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psb_c_vect_mod, only : psb_c_base_vect_type
use psb_c_base_vect_mod, only : psb_c_base_vect_type
use psb_c_base_multivect_mod, only : psb_c_base_multivect_type
interface psi_swapdata
@@ -63,6 +64,16 @@ module psi_c_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_vect
subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_multivect
subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -92,6 +103,17 @@ module psi_c_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_cswap_vidx_vect
subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_cswap_vidx_multivect
end interface
@@ -124,6 +146,16 @@ module psi_c_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_vect
subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_multivect
subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -153,6 +185,17 @@ module psi_c_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_vect
subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_multivect
end interface
interface psi_ovrl_upd
base/modules/psi_d_mod.f90
+44 -1
View File
@@ -31,7 +31,8 @@
!!$
module psi_d_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psb_d_vect_mod, only : psb_d_base_vect_type
use psb_d_base_vect_mod, only : psb_d_base_vect_type
use psb_d_base_multivect_mod, only : psb_d_base_multivect_type
interface psi_swapdata
@@ -63,6 +64,16 @@ module psi_d_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_vect
subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_multivect
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -92,6 +103,17 @@ module psi_d_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dswap_vidx_vect
subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dswap_vidx_multivect
end interface
@@ -124,6 +146,16 @@ module psi_d_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_vect
subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_multivect
subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -153,6 +185,17 @@ module psi_d_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_vect
subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_multivect
end interface
interface psi_ovrl_upd
base/modules/psi_i_mod.f90
+44 -1
View File
@@ -31,7 +31,8 @@
!!$
module psi_i_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpik_
use psb_i_vect_mod, only : psb_i_base_vect_type
use psb_i_base_vect_mod, only : psb_i_base_vect_type
use psb_i_base_multivect_mod, only : psb_i_base_multivect_type
interface
subroutine psi_compute_size(desc_data,&
@@ -223,6 +224,16 @@ module psi_i_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_vect
subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_multivect
subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -252,6 +263,17 @@ module psi_i_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_iswap_vidx_vect
subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_iswap_vidx_multivect
end interface
@@ -284,6 +306,16 @@ module psi_i_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_vect
subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_multivect
subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -313,6 +345,17 @@ module psi_i_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_vect
subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_multivect
end interface
interface psi_ovrl_upd
base/modules/psi_s_mod.f90
+44 -1
View File
@@ -31,7 +31,8 @@
!!$
module psi_s_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psb_s_vect_mod, only : psb_s_base_vect_type
use psb_s_base_vect_mod, only : psb_s_base_vect_type
use psb_s_base_multivect_mod, only : psb_s_base_multivect_type
interface psi_swapdata
@@ -63,6 +64,16 @@ module psi_s_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_vect
subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_multivect
subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -92,6 +103,17 @@ module psi_s_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_sswap_vidx_vect
subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_sswap_vidx_multivect
end interface
@@ -124,6 +146,16 @@ module psi_s_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_vect
subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_multivect
subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -153,6 +185,17 @@ module psi_s_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_vect
subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_multivect
end interface
interface psi_ovrl_upd
base/modules/psi_z_mod.f90
+44 -1
View File
@@ -31,7 +31,8 @@
!!$
module psi_z_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psb_z_vect_mod, only : psb_z_base_vect_type
use psb_z_base_vect_mod, only : psb_z_base_vect_type
use psb_z_base_multivect_mod, only : psb_z_base_multivect_type
interface psi_swapdata
@@ -63,6 +64,16 @@ module psi_z_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_vect
subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_multivect
subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -92,6 +103,17 @@ module psi_z_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_zswap_vidx_vect
subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_zswap_vidx_multivect
end interface
@@ -124,6 +146,16 @@ module psi_z_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_vect
subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_multivect
subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
@@ -153,6 +185,17 @@ module psi_z_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_vect
subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_multivect
end interface
interface psi_ovrl_upd