|
|
@ -925,7 +925,6 @@ contains
|
|
|
|
if (z%is_dev()) call z%sync()
|
|
|
|
if (z%is_dev()) call z%sync()
|
|
|
|
|
|
|
|
|
|
|
|
n = min(size(z%v), size(x), size(y))
|
|
|
|
n = min(size(z%v), size(x), size(y))
|
|
|
|
!!$ write(0,*) 'Mlt_a_2: ',n
|
|
|
|
|
|
|
|
if (alpha == czero) then
|
|
|
|
if (alpha == czero) then
|
|
|
|
if (beta == cone) then
|
|
|
|
if (beta == cone) then
|
|
|
|
return
|
|
|
|
return
|
|
|
@ -1192,26 +1191,6 @@ contains
|
|
|
|
call x%gth(n,idx%v(i:),x%combuf(i:))
|
|
|
|
call x%gth(n,idx%v(i:),x%combuf(i:))
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_gthzbuf
|
|
|
|
end subroutine c_base_gthzbuf
|
|
|
|
|
|
|
|
|
|
|
|
subroutine c_base_sctb_buf(i,n,idx,beta,y)
|
|
|
|
|
|
|
|
use psi_serial_mod
|
|
|
|
|
|
|
|
integer(psb_ipk_) :: i, n
|
|
|
|
|
|
|
|
class(psb_i_base_vect_type) :: idx
|
|
|
|
|
|
|
|
complex(psb_spk_) :: beta
|
|
|
|
|
|
|
|
class(psb_c_base_vect_type) :: y
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (.not.allocated(y%combuf)) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if (y%is_dev()) call y%sync()
|
|
|
|
|
|
|
|
if (idx%is_dev()) call idx%sync()
|
|
|
|
|
|
|
|
call y%sct(n,idx%v(i:),y%combuf(i:),beta)
|
|
|
|
|
|
|
|
call y%set_host()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_sctb_buf
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
!
|
|
|
|
!> Function base_device_wait:
|
|
|
|
!> Function base_device_wait:
|
|
|
|
!! \memberof psb_c_base_vect_type
|
|
|
|
!! \memberof psb_c_base_vect_type
|
|
|
@ -1329,6 +1308,26 @@ contains
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_sctb_x
|
|
|
|
end subroutine c_base_sctb_x
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
subroutine c_base_sctb_buf(i,n,idx,beta,y)
|
|
|
|
|
|
|
|
use psi_serial_mod
|
|
|
|
|
|
|
|
integer(psb_ipk_) :: i, n
|
|
|
|
|
|
|
|
class(psb_i_base_vect_type) :: idx
|
|
|
|
|
|
|
|
complex(psb_spk_) :: beta
|
|
|
|
|
|
|
|
class(psb_c_base_vect_type) :: y
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (.not.allocated(y%combuf)) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf')
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
if (y%is_dev()) call y%sync()
|
|
|
|
|
|
|
|
if (idx%is_dev()) call idx%sync()
|
|
|
|
|
|
|
|
call y%sct(n,idx%v(i:),y%combuf(i:),beta)
|
|
|
|
|
|
|
|
call y%set_host()
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_sctb_buf
|
|
|
|
|
|
|
|
|
|
|
|
end module psb_c_base_vect_mod
|
|
|
|
end module psb_c_base_vect_mod
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -1415,20 +1414,23 @@ module psb_c_base_multivect_mod
|
|
|
|
procedure, pass(y) :: axpby_v => c_base_mlv_axpby_v
|
|
|
|
procedure, pass(y) :: axpby_v => c_base_mlv_axpby_v
|
|
|
|
procedure, pass(y) :: axpby_a => c_base_mlv_axpby_a
|
|
|
|
procedure, pass(y) :: axpby_a => c_base_mlv_axpby_a
|
|
|
|
generic, public :: axpby => axpby_v, axpby_a
|
|
|
|
generic, public :: axpby => axpby_v, axpby_a
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ ! Vector by vector multiplication. Need all variants
|
|
|
|
! MultiVector by vector/multivector multiplication. Need all variants
|
|
|
|
!!$ ! to handle multiple requirements from preconditioners
|
|
|
|
! to handle multiple requirements from preconditioners
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ procedure, pass(y) :: mlt_v => c_base_mlv_mlt_v
|
|
|
|
procedure, pass(y) :: mlt_mv => c_base_mlv_mlt_mv
|
|
|
|
!!$ procedure, pass(y) :: mlt_a => c_base_mlv_mlt_a
|
|
|
|
procedure, pass(y) :: mlt_mv_v => c_base_mlv_mlt_mv_v
|
|
|
|
!!$ procedure, pass(z) :: mlt_a_2 => c_base_mlv_mlt_a_2
|
|
|
|
procedure, pass(y) :: mlt_ar1 => c_base_mlv_mlt_ar1
|
|
|
|
!!$ procedure, pass(z) :: mlt_v_2 => c_base_mlv_mlt_v_2
|
|
|
|
procedure, pass(y) :: mlt_ar2 => c_base_mlv_mlt_ar2
|
|
|
|
|
|
|
|
procedure, pass(z) :: mlt_a_2 => c_base_mlv_mlt_a_2
|
|
|
|
|
|
|
|
procedure, pass(z) :: mlt_v_2 => c_base_mlv_mlt_v_2
|
|
|
|
!!$ procedure, pass(z) :: mlt_va => c_base_mlv_mlt_va
|
|
|
|
!!$ procedure, pass(z) :: mlt_va => c_base_mlv_mlt_va
|
|
|
|
!!$ procedure, pass(z) :: mlt_av => c_base_mlv_mlt_av
|
|
|
|
!!$ procedure, pass(z) :: mlt_av => c_base_mlv_mlt_av
|
|
|
|
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va
|
|
|
|
generic, public :: mlt => mlt_mv, mlt_mv_v, mlt_ar1, mlt_ar2, &
|
|
|
|
!!$ !
|
|
|
|
& mlt_a_2, mlt_v_2 !, mlt_av, mlt_va
|
|
|
|
!!$ ! Scaling and norms
|
|
|
|
!
|
|
|
|
!!$ !
|
|
|
|
! Scaling and norms
|
|
|
|
|
|
|
|
!
|
|
|
|
procedure, pass(x) :: scal => c_base_mlv_scal
|
|
|
|
procedure, pass(x) :: scal => c_base_mlv_scal
|
|
|
|
procedure, pass(x) :: nrm2 => c_base_mlv_nrm2
|
|
|
|
procedure, pass(x) :: nrm2 => c_base_mlv_nrm2
|
|
|
|
procedure, pass(x) :: amax => c_base_mlv_amax
|
|
|
|
procedure, pass(x) :: amax => c_base_mlv_amax
|
|
|
@ -1444,9 +1446,9 @@ module psb_c_base_multivect_mod
|
|
|
|
procedure, pass(x) :: gthzv => c_base_mlv_gthzv
|
|
|
|
procedure, pass(x) :: gthzv => c_base_mlv_gthzv
|
|
|
|
procedure, pass(x) :: gthzv_x => c_base_mlv_gthzv_x
|
|
|
|
procedure, pass(x) :: gthzv_x => c_base_mlv_gthzv_x
|
|
|
|
generic, public :: gth => gthab, gthzv, gthzv_x
|
|
|
|
generic, public :: gth => gthab, gthzv, gthzv_x
|
|
|
|
!!$ procedure, pass(y) :: sctb => c_base_mlv_sctb
|
|
|
|
procedure, pass(y) :: sctb => c_base_mlv_sctb
|
|
|
|
!!$ procedure, pass(y) :: sctb_x => c_base_mlv_sctb_x
|
|
|
|
procedure, pass(y) :: sctb_x => c_base_mlv_sctb_x
|
|
|
|
!!$ generic, public :: sct => sctb, sctb_x
|
|
|
|
generic, public :: sct => sctb, sctb_x
|
|
|
|
end type psb_c_base_multivect_type
|
|
|
|
end type psb_c_base_multivect_type
|
|
|
|
|
|
|
|
|
|
|
|
interface psb_c_base_multivect
|
|
|
|
interface psb_c_base_multivect
|
|
|
@ -2082,183 +2084,194 @@ contains
|
|
|
|
end subroutine c_base_mlv_axpby_a
|
|
|
|
end subroutine c_base_mlv_axpby_a
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ ! Multiple variants of two operations:
|
|
|
|
! Multiple variants of two operations:
|
|
|
|
!!$ ! Simple multiplication Y(:) = X(:)*Y(:)
|
|
|
|
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
|
|
|
|
!!$ ! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:)
|
|
|
|
! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:)
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ ! Variants expanded according to the dynamic type
|
|
|
|
! Variants expanded according to the dynamic type
|
|
|
|
!!$ ! of the involved entities
|
|
|
|
! of the involved entities
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ !> Function base_mlv_mlt_a
|
|
|
|
!> Function base_mlv_mlt_mv
|
|
|
|
!!$ !! \memberof psb_c_base_multivect_type
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ !! \brief Vector entry-by-entry multiply by a base_mlv_vect array y=x*y
|
|
|
|
!! \brief Multivector entry-by-entry multiply by a base_mlv_multivect y=x*y
|
|
|
|
!!$ !! \param x The class(base_mlv_vect) to be multiplied by
|
|
|
|
!! \param x The class(base_mlv_vect) to be multiplied by
|
|
|
|
!!$ !! \param info return code
|
|
|
|
!! \param info return code
|
|
|
|
!!$ !!
|
|
|
|
!!
|
|
|
|
!!$ subroutine c_base_mlv_mlt_v(x, y, info)
|
|
|
|
subroutine c_base_mlv_mlt_mv(x, y, info)
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ implicit none
|
|
|
|
implicit none
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!$ integer(psb_ipk_), intent(out) :: info
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ integer(psb_ipk_) :: i, n
|
|
|
|
|
|
|
|
!!$
|
|
|
|
info = 0
|
|
|
|
!!$ info = 0
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
!!$ select type(xx => x)
|
|
|
|
call y%mlt(x%v,info)
|
|
|
|
!!$ type is (psb_c_base_multivect_type)
|
|
|
|
|
|
|
|
!!$ n = min(size(y%v), size(xx%v))
|
|
|
|
end subroutine c_base_mlv_mlt_mv
|
|
|
|
!!$ do i=1, n
|
|
|
|
|
|
|
|
!!$ y%v(i) = y%v(i)*xx%v(i)
|
|
|
|
subroutine c_base_mlv_mlt_mv_v(x, y, info)
|
|
|
|
!!$ end do
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ class default
|
|
|
|
implicit none
|
|
|
|
!!$ call y%mlt(x%v,info)
|
|
|
|
class(psb_c_base_vect_type), intent(inout) :: x
|
|
|
|
!!$ end select
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!$
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ end subroutine c_base_mlv_mlt_v
|
|
|
|
|
|
|
|
!!$
|
|
|
|
info = 0
|
|
|
|
!!$ !
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
!!$ !> Function base_mlv_mlt_a
|
|
|
|
call y%mlt(x%v,info)
|
|
|
|
!!$ !! \memberof psb_c_base_multivect_type
|
|
|
|
|
|
|
|
!!$ !! \brief Vector entry-by-entry multiply by a normal array y=x*y
|
|
|
|
end subroutine c_base_mlv_mlt_mv_v
|
|
|
|
!!$ !! \param x(:) The array to be multiplied by
|
|
|
|
|
|
|
|
!!$ !! \param info return code
|
|
|
|
!
|
|
|
|
!!$ !!
|
|
|
|
!> Function base_mlv_mlt_ar1
|
|
|
|
!!$ subroutine c_base_mlv_mlt_a(x, y, info)
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
!! \brief MultiVector entry-by-entry multiply by a rank 1 array y=x*y
|
|
|
|
!!$ implicit none
|
|
|
|
!! \param x(:) The array to be multiplied by
|
|
|
|
!!$ complex(psb_spk_), intent(in) :: x(:)
|
|
|
|
!! \param info return code
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!
|
|
|
|
!!$ integer(psb_ipk_), intent(out) :: info
|
|
|
|
subroutine c_base_mlv_mlt_ar1(x, y, info)
|
|
|
|
!!$ integer(psb_ipk_) :: i, n
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$
|
|
|
|
implicit none
|
|
|
|
!!$ info = 0
|
|
|
|
complex(psb_spk_), intent(in) :: x(:)
|
|
|
|
!!$ n = min(size(y%v), size(x))
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!$ do i=1, n
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ y%v(i) = y%v(i)*x(i)
|
|
|
|
integer(psb_ipk_) :: i, n
|
|
|
|
!!$ end do
|
|
|
|
|
|
|
|
!!$
|
|
|
|
info = 0
|
|
|
|
!!$ end subroutine c_base_mlv_mlt_a
|
|
|
|
n = min(psb_size(y%v,1), size(x))
|
|
|
|
!!$
|
|
|
|
do i=1, n
|
|
|
|
!!$
|
|
|
|
y%v(i,:) = y%v(i,:)*x(i)
|
|
|
|
!!$ !
|
|
|
|
end do
|
|
|
|
!!$ !> Function base_mlv_mlt_a_2
|
|
|
|
|
|
|
|
!!$ !! \memberof psb_c_base_multivect_type
|
|
|
|
end subroutine c_base_mlv_mlt_ar1
|
|
|
|
!!$ !! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays
|
|
|
|
|
|
|
|
!!$ !! z=beta*z+alpha*x*y
|
|
|
|
!
|
|
|
|
!!$ !! \param alpha
|
|
|
|
!> Function base_mlv_mlt_ar2
|
|
|
|
!!$ !! \param beta
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ !! \param x(:) The array to be multiplied b
|
|
|
|
!! \brief MultiVector entry-by-entry multiply by a rank 2 array y=x*y
|
|
|
|
!!$ !! \param y(:) The array to be multiplied by
|
|
|
|
!! \param x(:,:) The array to be multiplied by
|
|
|
|
!!$ !! \param info return code
|
|
|
|
!! \param info return code
|
|
|
|
!!$ !!
|
|
|
|
!!
|
|
|
|
!!$ subroutine c_base_mlv_mlt_a_2(alpha,x,y,beta,z,info)
|
|
|
|
subroutine c_base_mlv_mlt_ar2(x, y, info)
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ implicit none
|
|
|
|
implicit none
|
|
|
|
!!$ complex(psb_spk_), intent(in) :: alpha,beta
|
|
|
|
complex(psb_spk_), intent(in) :: x(:,:)
|
|
|
|
!!$ complex(psb_spk_), intent(in) :: y(:)
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!$ complex(psb_spk_), intent(in) :: x(:)
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: z
|
|
|
|
integer(psb_ipk_) :: i, nr,nc
|
|
|
|
!!$ integer(psb_ipk_), intent(out) :: info
|
|
|
|
|
|
|
|
!!$ integer(psb_ipk_) :: i, n
|
|
|
|
info = 0
|
|
|
|
!!$
|
|
|
|
nr = min(psb_size(y%v,1), size(x,1))
|
|
|
|
!!$ info = 0
|
|
|
|
nc = min(psb_size(y%v,2), size(x,2))
|
|
|
|
!!$ n = min(size(z%v), size(x), size(y))
|
|
|
|
y%v(1:nr,1:nc) = y%v(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ if (alpha == izero) then
|
|
|
|
|
|
|
|
!!$ if (beta == ione) then
|
|
|
|
end subroutine c_base_mlv_mlt_ar2
|
|
|
|
!!$ return
|
|
|
|
|
|
|
|
!!$ else
|
|
|
|
|
|
|
|
!!$ do i=1, n
|
|
|
|
!
|
|
|
|
!!$ z%v(i) = beta*z%v(i)
|
|
|
|
!> Function base_mlv_mlt_a_2
|
|
|
|
!!$ end do
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ end if
|
|
|
|
!! \brief AXPBY-like Vector entry-by-entry multiply by normal arrays
|
|
|
|
!!$ else
|
|
|
|
!! z=beta*z+alpha*x*y
|
|
|
|
!!$ if (alpha == ione) then
|
|
|
|
!! \param alpha
|
|
|
|
!!$ if (beta == izero) then
|
|
|
|
!! \param beta
|
|
|
|
!!$ do i=1, n
|
|
|
|
!! \param x(:) The array to be multiplied b
|
|
|
|
!!$ z%v(i) = y(i)*x(i)
|
|
|
|
!! \param y(:) The array to be multiplied by
|
|
|
|
!!$ end do
|
|
|
|
!! \param info return code
|
|
|
|
!!$ else if (beta == ione) then
|
|
|
|
!!
|
|
|
|
!!$ do i=1, n
|
|
|
|
subroutine c_base_mlv_mlt_a_2(alpha,x,y,beta,z,info)
|
|
|
|
!!$ z%v(i) = z%v(i) + y(i)*x(i)
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ end do
|
|
|
|
implicit none
|
|
|
|
!!$ else
|
|
|
|
complex(psb_spk_), intent(in) :: alpha,beta
|
|
|
|
!!$ do i=1, n
|
|
|
|
complex(psb_spk_), intent(in) :: y(:,:)
|
|
|
|
!!$ z%v(i) = beta*z%v(i) + y(i)*x(i)
|
|
|
|
complex(psb_spk_), intent(in) :: x(:,:)
|
|
|
|
!!$ end do
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: z
|
|
|
|
!!$ end if
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ else if (alpha == -ione) then
|
|
|
|
integer(psb_ipk_) :: i, nr, nc
|
|
|
|
!!$ if (beta == izero) then
|
|
|
|
|
|
|
|
!!$ do i=1, n
|
|
|
|
info = 0
|
|
|
|
!!$ z%v(i) = -y(i)*x(i)
|
|
|
|
nr = min(psb_size(z%v,1), size(x,1), size(y,1))
|
|
|
|
!!$ end do
|
|
|
|
nc = min(psb_size(z%v,2), size(x,2), size(y,2))
|
|
|
|
!!$ else if (beta == ione) then
|
|
|
|
if (alpha == czero) then
|
|
|
|
!!$ do i=1, n
|
|
|
|
if (beta == cone) then
|
|
|
|
!!$ z%v(i) = z%v(i) - y(i)*x(i)
|
|
|
|
return
|
|
|
|
!!$ end do
|
|
|
|
else
|
|
|
|
!!$ else
|
|
|
|
z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc)
|
|
|
|
!!$ do i=1, n
|
|
|
|
end if
|
|
|
|
!!$ z%v(i) = beta*z%v(i) - y(i)*x(i)
|
|
|
|
else
|
|
|
|
!!$ end do
|
|
|
|
if (alpha == cone) then
|
|
|
|
!!$ end if
|
|
|
|
if (beta == czero) then
|
|
|
|
!!$ else
|
|
|
|
z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ if (beta == izero) then
|
|
|
|
else if (beta == cone) then
|
|
|
|
!!$ do i=1, n
|
|
|
|
z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ z%v(i) = alpha*y(i)*x(i)
|
|
|
|
else
|
|
|
|
!!$ end do
|
|
|
|
z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ else if (beta == ione) then
|
|
|
|
end if
|
|
|
|
!!$ do i=1, n
|
|
|
|
else if (alpha == -cone) then
|
|
|
|
!!$ z%v(i) = z%v(i) + alpha*y(i)*x(i)
|
|
|
|
if (beta == czero) then
|
|
|
|
!!$ end do
|
|
|
|
z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ else
|
|
|
|
else if (beta == cone) then
|
|
|
|
!!$ do i=1, n
|
|
|
|
z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
|
|
|
|
else
|
|
|
|
!!$ end do
|
|
|
|
z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ end if
|
|
|
|
end if
|
|
|
|
!!$ end if
|
|
|
|
else
|
|
|
|
!!$ end if
|
|
|
|
if (beta == czero) then
|
|
|
|
!!$ end subroutine c_base_mlv_mlt_a_2
|
|
|
|
z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$
|
|
|
|
else if (beta == cone) then
|
|
|
|
!!$ !
|
|
|
|
z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ !> Function base_mlv_mlt_v_2
|
|
|
|
else
|
|
|
|
!!$ !! \memberof psb_c_base_multivect_type
|
|
|
|
z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc)
|
|
|
|
!!$ !! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect)
|
|
|
|
end if
|
|
|
|
!!$ !! z=beta*z+alpha*x*y
|
|
|
|
end if
|
|
|
|
!!$ !! \param alpha
|
|
|
|
end if
|
|
|
|
!!$ !! \param beta
|
|
|
|
end subroutine c_base_mlv_mlt_a_2
|
|
|
|
!!$ !! \param x The class(base_mlv_vect) to be multiplied b
|
|
|
|
|
|
|
|
!!$ !! \param y The class(base_mlv_vect) to be multiplied by
|
|
|
|
!
|
|
|
|
!!$ !! \param info return code
|
|
|
|
!> Function base_mlv_mlt_v_2
|
|
|
|
!!$ !!
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
|
|
|
|
!! \brief AXPBY-like Vector entry-by-entry multiply by class(base_mlv_vect)
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
!! z=beta*z+alpha*x*y
|
|
|
|
!!$ use psb_string_mod
|
|
|
|
!! \param alpha
|
|
|
|
!!$ implicit none
|
|
|
|
!! \param beta
|
|
|
|
!!$ complex(psb_spk_), intent(in) :: alpha,beta
|
|
|
|
!! \param x The class(base_mlv_vect) to be multiplied b
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
!! \param y The class(base_mlv_vect) to be multiplied by
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!! \param info return code
|
|
|
|
!!$ class(psb_c_base_multivect_type), intent(inout) :: z
|
|
|
|
!!
|
|
|
|
!!$ integer(psb_ipk_), intent(out) :: info
|
|
|
|
subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
|
|
|
|
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ integer(psb_ipk_) :: i, n
|
|
|
|
use psb_string_mod
|
|
|
|
!!$ logical :: conjgx_, conjgy_
|
|
|
|
implicit none
|
|
|
|
!!$
|
|
|
|
complex(psb_spk_), intent(in) :: alpha,beta
|
|
|
|
!!$ info = 0
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
!!$ if (.not.psb_i_is_complex_) then
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
!!$ call z%mlt(alpha,x%v,y%v,beta,info)
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: z
|
|
|
|
!!$ else
|
|
|
|
integer(psb_ipk_), intent(out) :: info
|
|
|
|
!!$ conjgx_=.false.
|
|
|
|
character(len=1), intent(in), optional :: conjgx, conjgy
|
|
|
|
!!$ if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
|
|
|
|
integer(psb_ipk_) :: i, n
|
|
|
|
!!$ conjgy_=.false.
|
|
|
|
logical :: conjgx_, conjgy_
|
|
|
|
!!$ if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
|
|
|
|
|
|
|
|
!!$ if (conjgx_) x%v=(x%v)
|
|
|
|
info = 0
|
|
|
|
!!$ if (conjgy_) y%v=(y%v)
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
!!$ call z%mlt(alpha,x%v,y%v,beta,info)
|
|
|
|
if (y%is_dev()) call y%sync()
|
|
|
|
!!$ if (conjgx_) x%v=(x%v)
|
|
|
|
if (z%is_dev()) call z%sync()
|
|
|
|
!!$ if (conjgy_) y%v=(y%v)
|
|
|
|
if (.not.psb_c_is_complex_) then
|
|
|
|
!!$ end if
|
|
|
|
call z%mlt(alpha,x%v,y%v,beta,info)
|
|
|
|
!!$ end subroutine c_base_mlv_mlt_v_2
|
|
|
|
else
|
|
|
|
|
|
|
|
conjgx_=.false.
|
|
|
|
|
|
|
|
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
|
|
|
|
|
|
|
|
conjgy_=.false.
|
|
|
|
|
|
|
|
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
|
|
|
|
|
|
|
|
if (conjgx_) x%v=conjg(x%v)
|
|
|
|
|
|
|
|
if (conjgy_) y%v=conjg(y%v)
|
|
|
|
|
|
|
|
call z%mlt(alpha,x%v,y%v,beta,info)
|
|
|
|
|
|
|
|
if (conjgx_) x%v=conjg(x%v)
|
|
|
|
|
|
|
|
if (conjgy_) y%v=conjg(y%v)
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
end subroutine c_base_mlv_mlt_v_2
|
|
|
|
!!$
|
|
|
|
!!$
|
|
|
|
!!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info)
|
|
|
|
!!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info)
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
!!$ use psi_serial_mod
|
|
|
@ -2400,7 +2413,7 @@ contains
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: x
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
class(psb_c_base_multivect_type), intent(inout) :: y
|
|
|
|
|
|
|
|
|
|
|
|
if (.not.x%is_host()) call x%sync()
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
if (allocated(x%v)) then
|
|
|
|
if (allocated(x%v)) then
|
|
|
|
call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info)
|
|
|
|
call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info)
|
|
|
|
call y%absval()
|
|
|
|
call y%absval()
|
|
|
@ -2428,7 +2441,7 @@ contains
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
integer(psb_ipk_) :: nc
|
|
|
|
integer(psb_ipk_) :: nc
|
|
|
|
|
|
|
|
|
|
|
|
call x%sync()
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
if (.not.allocated(x%v)) then
|
|
|
|
if (.not.allocated(x%v)) then
|
|
|
|
return
|
|
|
|
return
|
|
|
|
end if
|
|
|
|
end if
|
|
|
@ -2452,7 +2465,7 @@ contains
|
|
|
|
complex(psb_spk_) :: y(:)
|
|
|
|
complex(psb_spk_) :: y(:)
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
|
|
|
|
|
|
|
|
call x%sync()
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
call x%gth(n,idx%v(i:),y)
|
|
|
|
call x%gth(n,idx%v(i:),y)
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_mlv_gthzv_x
|
|
|
|
end subroutine c_base_mlv_gthzv_x
|
|
|
@ -2472,8 +2485,8 @@ contains
|
|
|
|
complex(psb_spk_) :: y(:)
|
|
|
|
complex(psb_spk_) :: y(:)
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
class(psb_c_base_multivect_type) :: x
|
|
|
|
integer(psb_ipk_) :: nc
|
|
|
|
integer(psb_ipk_) :: nc
|
|
|
|
|
|
|
|
|
|
|
|
call x%sync()
|
|
|
|
if (x%is_dev()) call x%sync()
|
|
|
|
if (.not.allocated(x%v)) then
|
|
|
|
if (.not.allocated(x%v)) then
|
|
|
|
return
|
|
|
|
return
|
|
|
|
end if
|
|
|
|
end if
|
|
|
@ -2483,40 +2496,42 @@ contains
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_mlv_gthzv
|
|
|
|
end subroutine c_base_mlv_gthzv
|
|
|
|
|
|
|
|
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ ! Scatter:
|
|
|
|
! Scatter:
|
|
|
|
!!$ ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:)
|
|
|
|
! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:)
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ !
|
|
|
|
!
|
|
|
|
!!$ !> Function base_mlv_sctb
|
|
|
|
!> Function base_mlv_sctb
|
|
|
|
!!$ !! \memberof psb_c_base_multivect_type
|
|
|
|
!! \memberof psb_c_base_multivect_type
|
|
|
|
!!$ !! \brief scatter into a class(base_mlv_vect)
|
|
|
|
!! \brief scatter into a class(base_mlv_vect)
|
|
|
|
!!$ !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:)
|
|
|
|
!! Y(IDX(:)) = beta * Y(IDX(:)) + X(:)
|
|
|
|
!!$ !! \param n how many entries to consider
|
|
|
|
!! \param n how many entries to consider
|
|
|
|
!!$ !! \param idx(:) indices
|
|
|
|
!! \param idx(:) indices
|
|
|
|
!!$ !! \param beta
|
|
|
|
!! \param beta
|
|
|
|
!!$ !! \param x(:)
|
|
|
|
!! \param x(:)
|
|
|
|
!!$ subroutine c_base_mlv_sctb(n,idx,x,beta,y)
|
|
|
|
subroutine c_base_mlv_sctb(n,idx,x,beta,y)
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ integer(psb_ipk_) :: n, idx(:)
|
|
|
|
integer(psb_ipk_) :: n, idx(:)
|
|
|
|
!!$ complex(psb_spk_) :: beta, x(:)
|
|
|
|
complex(psb_spk_) :: beta, x(:)
|
|
|
|
!!$ class(psb_c_base_multivect_type) :: y
|
|
|
|
class(psb_c_base_multivect_type) :: y
|
|
|
|
!!$
|
|
|
|
integer(psb_ipk_) :: nc
|
|
|
|
!!$ call y%sync()
|
|
|
|
|
|
|
|
!!$ call psi_sct(n,idx,x,beta,y%v)
|
|
|
|
if (y%is_dev()) call y%sync()
|
|
|
|
!!$ call y%set_host()
|
|
|
|
nc = psb_size(y%v,2)
|
|
|
|
!!$
|
|
|
|
call psi_sct(n,nc,idx,x,beta,y%v)
|
|
|
|
!!$ end subroutine c_base_mlv_sctb
|
|
|
|
call y%set_host()
|
|
|
|
!!$
|
|
|
|
|
|
|
|
!!$ subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y)
|
|
|
|
end subroutine c_base_mlv_sctb
|
|
|
|
!!$ use psi_serial_mod
|
|
|
|
|
|
|
|
!!$ integer(psb_ipk_) :: i, n
|
|
|
|
subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y)
|
|
|
|
!!$ class(psb_c_base_multivect_type) :: idx
|
|
|
|
use psi_serial_mod
|
|
|
|
!!$ complex( psb_spk_) :: beta, x(:)
|
|
|
|
integer(psb_ipk_) :: i, n
|
|
|
|
!!$ class(psb_c_base_multivect_type) :: y
|
|
|
|
class(psb_i_base_vect_type) :: idx
|
|
|
|
!!$
|
|
|
|
complex( psb_spk_) :: beta, x(:)
|
|
|
|
!!$ call y%sct(n,idx%v(i:),x,beta)
|
|
|
|
class(psb_c_base_multivect_type) :: y
|
|
|
|
!!$
|
|
|
|
|
|
|
|
!!$ end subroutine c_base_mlv_sctb_x
|
|
|
|
call y%sct(n,idx%v(i:),x,beta)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine c_base_mlv_sctb_x
|
|
|
|
end module psb_c_base_multivect_mod
|
|
|
|
end module psb_c_base_multivect_mod
|
|
|
|
|
|
|
|
|
|
|
|