fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_z_base_vect_mod.f90

Additional methods for multivectors.
psblas-3.4-maint
Salvatore Filippone 10 years ago
parent 585cf6f735
commit 1917e2212a
5 changed files with 1092 additions and 1032 deletions
Show Stats Download Patch File Download Diff File

519
base/modules/psb_c_base_vect_mod.f90
Unescape Escape View File

@ -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
@ -2473,7 +2486,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
@ -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

519
base/modules/psb_d_base_vect_mod.f90
Unescape Escape View File

@ -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 == dzero) then if (alpha == dzero) then
if (beta == done) then if (beta == done) 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 d_base_gthzbuf end subroutine d_base_gthzbuf
subroutine d_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_dpk_) :: beta
class(psb_d_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 d_base_sctb_buf
! !
!> Function base_device_wait: !> Function base_device_wait:
!! \memberof psb_d_base_vect_type !! \memberof psb_d_base_vect_type
@ -1329,6 +1308,26 @@ contains
end subroutine d_base_sctb_x end subroutine d_base_sctb_x
subroutine d_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_dpk_) :: beta
class(psb_d_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 d_base_sctb_buf
end module psb_d_base_vect_mod end module psb_d_base_vect_mod
@ -1415,20 +1414,23 @@ module psb_d_base_multivect_mod
procedure, pass(y) :: axpby_v => d_base_mlv_axpby_v procedure, pass(y) :: axpby_v => d_base_mlv_axpby_v
procedure, pass(y) :: axpby_a => d_base_mlv_axpby_a procedure, pass(y) :: axpby_a => d_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 => d_base_mlv_mlt_v procedure, pass(y) :: mlt_mv => d_base_mlv_mlt_mv
!!$ procedure, pass(y) :: mlt_a => d_base_mlv_mlt_a procedure, pass(y) :: mlt_mv_v => d_base_mlv_mlt_mv_v
!!$ procedure, pass(z) :: mlt_a_2 => d_base_mlv_mlt_a_2 procedure, pass(y) :: mlt_ar1 => d_base_mlv_mlt_ar1
!!$ procedure, pass(z) :: mlt_v_2 => d_base_mlv_mlt_v_2 procedure, pass(y) :: mlt_ar2 => d_base_mlv_mlt_ar2
procedure, pass(z) :: mlt_a_2 => d_base_mlv_mlt_a_2
procedure, pass(z) :: mlt_v_2 => d_base_mlv_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => d_base_mlv_mlt_va !!$ procedure, pass(z) :: mlt_va => d_base_mlv_mlt_va
!!$ procedure, pass(z) :: mlt_av => d_base_mlv_mlt_av !!$ procedure, pass(z) :: mlt_av => d_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 => d_base_mlv_scal procedure, pass(x) :: scal => d_base_mlv_scal
procedure, pass(x) :: nrm2 => d_base_mlv_nrm2 procedure, pass(x) :: nrm2 => d_base_mlv_nrm2
procedure, pass(x) :: amax => d_base_mlv_amax procedure, pass(x) :: amax => d_base_mlv_amax
@ -1444,9 +1446,9 @@ module psb_d_base_multivect_mod
procedure, pass(x) :: gthzv => d_base_mlv_gthzv procedure, pass(x) :: gthzv => d_base_mlv_gthzv
procedure, pass(x) :: gthzv_x => d_base_mlv_gthzv_x procedure, pass(x) :: gthzv_x => d_base_mlv_gthzv_x
generic, public :: gth => gthab, gthzv, gthzv_x generic, public :: gth => gthab, gthzv, gthzv_x
!!$ procedure, pass(y) :: sctb => d_base_mlv_sctb procedure, pass(y) :: sctb => d_base_mlv_sctb
!!$ procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x
!!$ generic, public :: sct => sctb, sctb_x generic, public :: sct => sctb, sctb_x
end type psb_d_base_multivect_type end type psb_d_base_multivect_type
interface psb_d_base_multivect interface psb_d_base_multivect
@ -2082,183 +2084,194 @@ contains
end subroutine d_base_mlv_axpby_a end subroutine d_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_d_base_multivect_type !! \memberof psb_d_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 d_base_mlv_mlt_v(x, y, info) subroutine d_base_mlv_mlt_mv(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ class(psb_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: x
!!$ class(psb_d_base_multivect_type), intent(inout) :: y class(psb_d_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_d_base_multivect_type)
!!$ n = min(size(y%v), size(xx%v)) end subroutine d_base_mlv_mlt_mv
!!$ do i=1, n
!!$ y%v(i) = y%v(i)*xx%v(i) subroutine d_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_d_base_vect_type), intent(inout) :: x
!!$ end select class(psb_d_base_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine d_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_d_base_multivect_type
!!$ !! \brief Vector entry-by-entry multiply by a normal array y=x*y end subroutine d_base_mlv_mlt_mv_v
!!$ !! \param x(:) The array to be multiplied by
!!$ !! \param info return code !
!!$ !! !> Function base_mlv_mlt_ar1
!!$ subroutine d_base_mlv_mlt_a(x, y, info) !! \memberof psb_d_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
!!$ real(psb_dpk_), intent(in) :: x(:) !! \param info return code
!!$ class(psb_d_base_multivect_type), intent(inout) :: y !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine d_base_mlv_mlt_ar1(x, y, info)
!!$ integer(psb_ipk_) :: i, n use psi_serial_mod
!!$ implicit none
!!$ info = 0 real(psb_dpk_), intent(in) :: x(:)
!!$ n = min(size(y%v), size(x)) class(psb_d_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 d_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_d_base_multivect_type end subroutine d_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_d_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 d_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) subroutine d_base_mlv_mlt_ar2(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: x(:,:)
!!$ real(psb_dpk_), intent(in) :: y(:) class(psb_d_base_multivect_type), intent(inout) :: y
!!$ real(psb_dpk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: info
!!$ class(psb_d_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 d_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_d_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 d_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 real(psb_dpk_), intent(in) :: alpha,beta
!!$ do i=1, n real(psb_dpk_), intent(in) :: y(:,:)
!!$ z%v(i) = beta*z%v(i) + y(i)*x(i) real(psb_dpk_), intent(in) :: x(:,:)
!!$ end do class(psb_d_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 == dzero) then
!!$ do i=1, n if (beta == done) 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 == done) then
!!$ end if if (beta == dzero) 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 == done) 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 == -done) then
!!$ z%v(i) = z%v(i) + alpha*y(i)*x(i) if (beta == dzero) then
!!$ end do z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc)
!!$ else else if (beta == done) 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 == dzero) then
!!$ end subroutine d_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 == done) 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_d_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 d_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_d_base_multivect_type
!!$ subroutine d_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
!!$ real(psb_dpk_), intent(in) :: alpha,beta !! \param x The class(base_mlv_vect) to be multiplied b
!!$ class(psb_d_base_multivect_type), intent(inout) :: x !! \param y The class(base_mlv_vect) to be multiplied by
!!$ class(psb_d_base_multivect_type), intent(inout) :: y !! \param info return code
!!$ class(psb_d_base_multivect_type), intent(inout) :: z !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine d_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
!!$ real(psb_dpk_), intent(in) :: alpha,beta
!!$ info = 0 class(psb_d_base_multivect_type), intent(inout) :: x
!!$ if (.not.psb_i_is_complex_) then class(psb_d_base_multivect_type), intent(inout) :: y
!!$ call z%mlt(alpha,x%v,y%v,beta,info) class(psb_d_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_d_is_complex_) then
!!$ end if call z%mlt(alpha,x%v,y%v,beta,info)
!!$ end subroutine d_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=(x%v)
if (conjgy_) y%v=(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
end if
end subroutine d_base_mlv_mlt_v_2
!!$ !!$
!!$ subroutine d_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ subroutine d_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_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: x
class(psb_d_base_multivect_type), intent(inout) :: y class(psb_d_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()),done,x,dzero,info) call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info)
call y%absval() call y%absval()
@ -2428,7 +2441,7 @@ contains
class(psb_d_base_multivect_type) :: x class(psb_d_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
real(psb_dpk_) :: y(:) real(psb_dpk_) :: y(:)
class(psb_d_base_multivect_type) :: x class(psb_d_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 d_base_mlv_gthzv_x end subroutine d_base_mlv_gthzv_x
@ -2473,7 +2486,7 @@ contains
class(psb_d_base_multivect_type) :: x class(psb_d_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 d_base_mlv_gthzv end subroutine d_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_d_base_multivect_type !! \memberof psb_d_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 d_base_mlv_sctb(n,idx,x,beta,y) subroutine d_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(:)
!!$ real(psb_dpk_) :: beta, x(:) real(psb_dpk_) :: beta, x(:)
!!$ class(psb_d_base_multivect_type) :: y class(psb_d_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 d_base_mlv_sctb call y%set_host()
!!$
!!$ subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) end subroutine d_base_mlv_sctb
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: i, n subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y)
!!$ class(psb_d_base_multivect_type) :: idx use psi_serial_mod
!!$ real( psb_dpk_) :: beta, x(:) integer(psb_ipk_) :: i, n
!!$ class(psb_d_base_multivect_type) :: y class(psb_i_base_vect_type) :: idx
!!$ real( psb_dpk_) :: beta, x(:)
!!$ call y%sct(n,idx%v(i:),x,beta) class(psb_d_base_multivect_type) :: y
!!$
!!$ end subroutine d_base_mlv_sctb_x call y%sct(n,idx%v(i:),x,beta)
end subroutine d_base_mlv_sctb_x
end module psb_d_base_multivect_mod end module psb_d_base_multivect_mod

40
base/modules/psb_i_base_vect_mod.f90
Unescape Escape View File

@ -732,26 +732,6 @@ contains
call x%gth(n,idx%v(i:),x%combuf(i:)) call x%gth(n,idx%v(i:),x%combuf(i:))
end subroutine i_base_gthzbuf end subroutine i_base_gthzbuf
subroutine i_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: beta
class(psb_i_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 i_base_sctb_buf
! !
!> Function base_device_wait: !> Function base_device_wait:
!! \memberof psb_i_base_vect_type !! \memberof psb_i_base_vect_type
@ -869,6 +849,26 @@ contains
end subroutine i_base_sctb_x end subroutine i_base_sctb_x
subroutine i_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
integer(psb_ipk_) :: beta
class(psb_i_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 i_base_sctb_buf
end module psb_i_base_vect_mod end module psb_i_base_vect_mod

519
base/modules/psb_s_base_vect_mod.f90
Unescape Escape View File

@ -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 == szero) then if (alpha == szero) then
if (beta == sone) then if (beta == sone) 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 s_base_gthzbuf end subroutine s_base_gthzbuf
subroutine s_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_spk_) :: beta
class(psb_s_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 s_base_sctb_buf
! !
!> Function base_device_wait: !> Function base_device_wait:
!! \memberof psb_s_base_vect_type !! \memberof psb_s_base_vect_type
@ -1329,6 +1308,26 @@ contains
end subroutine s_base_sctb_x end subroutine s_base_sctb_x
subroutine s_base_sctb_buf(i,n,idx,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: i, n
class(psb_i_base_vect_type) :: idx
real(psb_spk_) :: beta
class(psb_s_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 s_base_sctb_buf
end module psb_s_base_vect_mod end module psb_s_base_vect_mod
@ -1415,20 +1414,23 @@ module psb_s_base_multivect_mod
procedure, pass(y) :: axpby_v => s_base_mlv_axpby_v procedure, pass(y) :: axpby_v => s_base_mlv_axpby_v
procedure, pass(y) :: axpby_a => s_base_mlv_axpby_a procedure, pass(y) :: axpby_a => s_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 => s_base_mlv_mlt_v procedure, pass(y) :: mlt_mv => s_base_mlv_mlt_mv
!!$ procedure, pass(y) :: mlt_a => s_base_mlv_mlt_a procedure, pass(y) :: mlt_mv_v => s_base_mlv_mlt_mv_v
!!$ procedure, pass(z) :: mlt_a_2 => s_base_mlv_mlt_a_2 procedure, pass(y) :: mlt_ar1 => s_base_mlv_mlt_ar1
!!$ procedure, pass(z) :: mlt_v_2 => s_base_mlv_mlt_v_2 procedure, pass(y) :: mlt_ar2 => s_base_mlv_mlt_ar2
procedure, pass(z) :: mlt_a_2 => s_base_mlv_mlt_a_2
procedure, pass(z) :: mlt_v_2 => s_base_mlv_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => s_base_mlv_mlt_va !!$ procedure, pass(z) :: mlt_va => s_base_mlv_mlt_va
!!$ procedure, pass(z) :: mlt_av => s_base_mlv_mlt_av !!$ procedure, pass(z) :: mlt_av => s_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 => s_base_mlv_scal procedure, pass(x) :: scal => s_base_mlv_scal
procedure, pass(x) :: nrm2 => s_base_mlv_nrm2 procedure, pass(x) :: nrm2 => s_base_mlv_nrm2
procedure, pass(x) :: amax => s_base_mlv_amax procedure, pass(x) :: amax => s_base_mlv_amax
@ -1444,9 +1446,9 @@ module psb_s_base_multivect_mod
procedure, pass(x) :: gthzv => s_base_mlv_gthzv procedure, pass(x) :: gthzv => s_base_mlv_gthzv
procedure, pass(x) :: gthzv_x => s_base_mlv_gthzv_x procedure, pass(x) :: gthzv_x => s_base_mlv_gthzv_x
generic, public :: gth => gthab, gthzv, gthzv_x generic, public :: gth => gthab, gthzv, gthzv_x
!!$ procedure, pass(y) :: sctb => s_base_mlv_sctb procedure, pass(y) :: sctb => s_base_mlv_sctb
!!$ procedure, pass(y) :: sctb_x => s_base_mlv_sctb_x procedure, pass(y) :: sctb_x => s_base_mlv_sctb_x
!!$ generic, public :: sct => sctb, sctb_x generic, public :: sct => sctb, sctb_x
end type psb_s_base_multivect_type end type psb_s_base_multivect_type
interface psb_s_base_multivect interface psb_s_base_multivect
@ -2082,183 +2084,194 @@ contains
end subroutine s_base_mlv_axpby_a end subroutine s_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_s_base_multivect_type !! \memberof psb_s_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 s_base_mlv_mlt_v(x, y, info) subroutine s_base_mlv_mlt_mv(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ class(psb_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: x
!!$ class(psb_s_base_multivect_type), intent(inout) :: y class(psb_s_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_s_base_multivect_type)
!!$ n = min(size(y%v), size(xx%v)) end subroutine s_base_mlv_mlt_mv
!!$ do i=1, n
!!$ y%v(i) = y%v(i)*xx%v(i) subroutine s_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_s_base_vect_type), intent(inout) :: x
!!$ end select class(psb_s_base_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine s_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_s_base_multivect_type
!!$ !! \brief Vector entry-by-entry multiply by a normal array y=x*y end subroutine s_base_mlv_mlt_mv_v
!!$ !! \param x(:) The array to be multiplied by
!!$ !! \param info return code !
!!$ !! !> Function base_mlv_mlt_ar1
!!$ subroutine s_base_mlv_mlt_a(x, y, info) !! \memberof psb_s_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
!!$ real(psb_spk_), intent(in) :: x(:) !! \param info return code
!!$ class(psb_s_base_multivect_type), intent(inout) :: y !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine s_base_mlv_mlt_ar1(x, y, info)
!!$ integer(psb_ipk_) :: i, n use psi_serial_mod
!!$ implicit none
!!$ info = 0 real(psb_spk_), intent(in) :: x(:)
!!$ n = min(size(y%v), size(x)) class(psb_s_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 s_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_s_base_multivect_type end subroutine s_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_s_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 s_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) subroutine s_base_mlv_mlt_ar2(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: x(:,:)
!!$ real(psb_spk_), intent(in) :: y(:) class(psb_s_base_multivect_type), intent(inout) :: y
!!$ real(psb_spk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: info
!!$ class(psb_s_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 s_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_s_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 s_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 real(psb_spk_), intent(in) :: alpha,beta
!!$ do i=1, n real(psb_spk_), intent(in) :: y(:,:)
!!$ z%v(i) = beta*z%v(i) + y(i)*x(i) real(psb_spk_), intent(in) :: x(:,:)
!!$ end do class(psb_s_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 == szero) then
!!$ do i=1, n if (beta == sone) 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 == sone) then
!!$ end if if (beta == szero) 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 == sone) 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 == -sone) then
!!$ z%v(i) = z%v(i) + alpha*y(i)*x(i) if (beta == szero) then
!!$ end do z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc)
!!$ else else if (beta == sone) 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 == szero) then
!!$ end subroutine s_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 == sone) 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_s_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 s_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_s_base_multivect_type
!!$ subroutine s_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
!!$ real(psb_spk_), intent(in) :: alpha,beta !! \param x The class(base_mlv_vect) to be multiplied b
!!$ class(psb_s_base_multivect_type), intent(inout) :: x !! \param y The class(base_mlv_vect) to be multiplied by
!!$ class(psb_s_base_multivect_type), intent(inout) :: y !! \param info return code
!!$ class(psb_s_base_multivect_type), intent(inout) :: z !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine s_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
!!$ real(psb_spk_), intent(in) :: alpha,beta
!!$ info = 0 class(psb_s_base_multivect_type), intent(inout) :: x
!!$ if (.not.psb_i_is_complex_) then class(psb_s_base_multivect_type), intent(inout) :: y
!!$ call z%mlt(alpha,x%v,y%v,beta,info) class(psb_s_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_s_is_complex_) then
!!$ end if call z%mlt(alpha,x%v,y%v,beta,info)
!!$ end subroutine s_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=(x%v)
if (conjgy_) y%v=(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
end if
end subroutine s_base_mlv_mlt_v_2
!!$ !!$
!!$ subroutine s_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ subroutine s_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_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: x
class(psb_s_base_multivect_type), intent(inout) :: y class(psb_s_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()),sone,x,szero,info) call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info)
call y%absval() call y%absval()
@ -2428,7 +2441,7 @@ contains
class(psb_s_base_multivect_type) :: x class(psb_s_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
real(psb_spk_) :: y(:) real(psb_spk_) :: y(:)
class(psb_s_base_multivect_type) :: x class(psb_s_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 s_base_mlv_gthzv_x end subroutine s_base_mlv_gthzv_x
@ -2473,7 +2486,7 @@ contains
class(psb_s_base_multivect_type) :: x class(psb_s_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 s_base_mlv_gthzv end subroutine s_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_s_base_multivect_type !! \memberof psb_s_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 s_base_mlv_sctb(n,idx,x,beta,y) subroutine s_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(:)
!!$ real(psb_spk_) :: beta, x(:) real(psb_spk_) :: beta, x(:)
!!$ class(psb_s_base_multivect_type) :: y class(psb_s_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 s_base_mlv_sctb call y%set_host()
!!$
!!$ subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) end subroutine s_base_mlv_sctb
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: i, n subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y)
!!$ class(psb_s_base_multivect_type) :: idx use psi_serial_mod
!!$ real( psb_spk_) :: beta, x(:) integer(psb_ipk_) :: i, n
!!$ class(psb_s_base_multivect_type) :: y class(psb_i_base_vect_type) :: idx
!!$ real( psb_spk_) :: beta, x(:)
!!$ call y%sct(n,idx%v(i:),x,beta) class(psb_s_base_multivect_type) :: y
!!$
!!$ end subroutine s_base_mlv_sctb_x call y%sct(n,idx%v(i:),x,beta)
end subroutine s_base_mlv_sctb_x
end module psb_s_base_multivect_mod end module psb_s_base_multivect_mod

519
base/modules/psb_z_base_vect_mod.f90
Unescape Escape View File

@ -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 == zzero) then if (alpha == zzero) then
if (beta == zone) then if (beta == zone) 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 z_base_gthzbuf end subroutine z_base_gthzbuf
subroutine z_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_dpk_) :: beta
class(psb_z_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 z_base_sctb_buf
! !
!> Function base_device_wait: !> Function base_device_wait:
!! \memberof psb_z_base_vect_type !! \memberof psb_z_base_vect_type
@ -1329,6 +1308,26 @@ contains
end subroutine z_base_sctb_x end subroutine z_base_sctb_x
subroutine z_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_dpk_) :: beta
class(psb_z_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 z_base_sctb_buf
end module psb_z_base_vect_mod end module psb_z_base_vect_mod
@ -1415,20 +1414,23 @@ module psb_z_base_multivect_mod
procedure, pass(y) :: axpby_v => z_base_mlv_axpby_v procedure, pass(y) :: axpby_v => z_base_mlv_axpby_v
procedure, pass(y) :: axpby_a => z_base_mlv_axpby_a procedure, pass(y) :: axpby_a => z_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 => z_base_mlv_mlt_v procedure, pass(y) :: mlt_mv => z_base_mlv_mlt_mv
!!$ procedure, pass(y) :: mlt_a => z_base_mlv_mlt_a procedure, pass(y) :: mlt_mv_v => z_base_mlv_mlt_mv_v
!!$ procedure, pass(z) :: mlt_a_2 => z_base_mlv_mlt_a_2 procedure, pass(y) :: mlt_ar1 => z_base_mlv_mlt_ar1
!!$ procedure, pass(z) :: mlt_v_2 => z_base_mlv_mlt_v_2 procedure, pass(y) :: mlt_ar2 => z_base_mlv_mlt_ar2
procedure, pass(z) :: mlt_a_2 => z_base_mlv_mlt_a_2
procedure, pass(z) :: mlt_v_2 => z_base_mlv_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => z_base_mlv_mlt_va !!$ procedure, pass(z) :: mlt_va => z_base_mlv_mlt_va
!!$ procedure, pass(z) :: mlt_av => z_base_mlv_mlt_av !!$ procedure, pass(z) :: mlt_av => z_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 => z_base_mlv_scal procedure, pass(x) :: scal => z_base_mlv_scal
procedure, pass(x) :: nrm2 => z_base_mlv_nrm2 procedure, pass(x) :: nrm2 => z_base_mlv_nrm2
procedure, pass(x) :: amax => z_base_mlv_amax procedure, pass(x) :: amax => z_base_mlv_amax
@ -1444,9 +1446,9 @@ module psb_z_base_multivect_mod
procedure, pass(x) :: gthzv => z_base_mlv_gthzv procedure, pass(x) :: gthzv => z_base_mlv_gthzv
procedure, pass(x) :: gthzv_x => z_base_mlv_gthzv_x procedure, pass(x) :: gthzv_x => z_base_mlv_gthzv_x
generic, public :: gth => gthab, gthzv, gthzv_x generic, public :: gth => gthab, gthzv, gthzv_x
!!$ procedure, pass(y) :: sctb => z_base_mlv_sctb procedure, pass(y) :: sctb => z_base_mlv_sctb
!!$ procedure, pass(y) :: sctb_x => z_base_mlv_sctb_x procedure, pass(y) :: sctb_x => z_base_mlv_sctb_x
!!$ generic, public :: sct => sctb, sctb_x generic, public :: sct => sctb, sctb_x
end type psb_z_base_multivect_type end type psb_z_base_multivect_type
interface psb_z_base_multivect interface psb_z_base_multivect
@ -2082,183 +2084,194 @@ contains
end subroutine z_base_mlv_axpby_a end subroutine z_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_z_base_multivect_type !! \memberof psb_z_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 z_base_mlv_mlt_v(x, y, info) subroutine z_base_mlv_mlt_mv(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ class(psb_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: x
!!$ class(psb_z_base_multivect_type), intent(inout) :: y class(psb_z_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_z_base_multivect_type)
!!$ n = min(size(y%v), size(xx%v)) end subroutine z_base_mlv_mlt_mv
!!$ do i=1, n
!!$ y%v(i) = y%v(i)*xx%v(i) subroutine z_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_z_base_vect_type), intent(inout) :: x
!!$ end select class(psb_z_base_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine z_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_z_base_multivect_type
!!$ !! \brief Vector entry-by-entry multiply by a normal array y=x*y end subroutine z_base_mlv_mlt_mv_v
!!$ !! \param x(:) The array to be multiplied by
!!$ !! \param info return code !
!!$ !! !> Function base_mlv_mlt_ar1
!!$ subroutine z_base_mlv_mlt_a(x, y, info) !! \memberof psb_z_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_dpk_), intent(in) :: x(:) !! \param info return code
!!$ class(psb_z_base_multivect_type), intent(inout) :: y !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine z_base_mlv_mlt_ar1(x, y, info)
!!$ integer(psb_ipk_) :: i, n use psi_serial_mod
!!$ implicit none
!!$ info = 0 complex(psb_dpk_), intent(in) :: x(:)
!!$ n = min(size(y%v), size(x)) class(psb_z_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 z_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_z_base_multivect_type end subroutine z_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_z_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 z_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) subroutine z_base_mlv_mlt_ar2(x, y, info)
!!$ use psi_serial_mod use psi_serial_mod
!!$ implicit none implicit none
!!$ complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: x(:,:)
!!$ complex(psb_dpk_), intent(in) :: y(:) class(psb_z_base_multivect_type), intent(inout) :: y
!!$ complex(psb_dpk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: info
!!$ class(psb_z_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 z_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_z_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 z_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_dpk_), intent(in) :: alpha,beta
!!$ do i=1, n complex(psb_dpk_), intent(in) :: y(:,:)
!!$ z%v(i) = beta*z%v(i) + y(i)*x(i) complex(psb_dpk_), intent(in) :: x(:,:)
!!$ end do class(psb_z_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 == zzero) then
!!$ do i=1, n if (beta == zone) 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 == zone) then
!!$ end if if (beta == zzero) 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 == zone) 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 == -zone) then
!!$ z%v(i) = z%v(i) + alpha*y(i)*x(i) if (beta == zzero) then
!!$ end do z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc)
!!$ else else if (beta == zone) 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 == zzero) then
!!$ end subroutine z_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 == zone) 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_z_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 z_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_z_base_multivect_type
!!$ subroutine z_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_dpk_), intent(in) :: alpha,beta !! \param x The class(base_mlv_vect) to be multiplied b
!!$ class(psb_z_base_multivect_type), intent(inout) :: x !! \param y The class(base_mlv_vect) to be multiplied by
!!$ class(psb_z_base_multivect_type), intent(inout) :: y !! \param info return code
!!$ class(psb_z_base_multivect_type), intent(inout) :: z !!
!!$ integer(psb_ipk_), intent(out) :: info subroutine z_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_dpk_), intent(in) :: alpha,beta
!!$ info = 0 class(psb_z_base_multivect_type), intent(inout) :: x
!!$ if (.not.psb_i_is_complex_) then class(psb_z_base_multivect_type), intent(inout) :: y
!!$ call z%mlt(alpha,x%v,y%v,beta,info) class(psb_z_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_z_is_complex_) then
!!$ end if call z%mlt(alpha,x%v,y%v,beta,info)
!!$ end subroutine z_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 z_base_mlv_mlt_v_2
!!$ !!$
!!$ subroutine z_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ subroutine z_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_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: x
class(psb_z_base_multivect_type), intent(inout) :: y class(psb_z_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()),zone,x,zzero,info) call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info)
call y%absval() call y%absval()
@ -2428,7 +2441,7 @@ contains
class(psb_z_base_multivect_type) :: x class(psb_z_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_dpk_) :: y(:) complex(psb_dpk_) :: y(:)
class(psb_z_base_multivect_type) :: x class(psb_z_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 z_base_mlv_gthzv_x end subroutine z_base_mlv_gthzv_x
@ -2473,7 +2486,7 @@ contains
class(psb_z_base_multivect_type) :: x class(psb_z_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 z_base_mlv_gthzv end subroutine z_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_z_base_multivect_type !! \memberof psb_z_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 z_base_mlv_sctb(n,idx,x,beta,y) subroutine z_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_dpk_) :: beta, x(:) complex(psb_dpk_) :: beta, x(:)
!!$ class(psb_z_base_multivect_type) :: y class(psb_z_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 z_base_mlv_sctb call y%set_host()
!!$
!!$ subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) end subroutine z_base_mlv_sctb
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: i, n subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y)
!!$ class(psb_z_base_multivect_type) :: idx use psi_serial_mod
!!$ complex( psb_dpk_) :: beta, x(:) integer(psb_ipk_) :: i, n
!!$ class(psb_z_base_multivect_type) :: y class(psb_i_base_vect_type) :: idx
!!$ complex( psb_dpk_) :: beta, x(:)
!!$ call y%sct(n,idx%v(i:),x,beta) class(psb_z_base_multivect_type) :: y
!!$
!!$ end subroutine z_base_mlv_sctb_x call y%sct(n,idx%v(i:),x,beta)
end subroutine z_base_mlv_sctb_x
end module psb_z_base_multivect_mod end module psb_z_base_multivect_mod

Write Preview
Loading…
Cancel
Save