mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-24 14:51:49 +00:00
Added implementation of multivector operations for all type/kinds
This commit is contained in:
@@ -529,6 +529,15 @@ module psb_c_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=1), intent(in), optional :: conjgx, conjgy
|
||||
end subroutine psb_cmlt_vect2
|
||||
subroutine psb_cmlt_multivect(x, y, res, desc_a,info,global)
|
||||
import :: psb_desc_type, psb_spk_, psb_ipk_, &
|
||||
& psb_c_multivect_type, psb_cspmat_type
|
||||
complex(psb_spk_), dimension(:,:), allocatable, intent(inout) :: res
|
||||
type(psb_c_multivect_type), intent(inout) :: x, y
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine psb_cmlt_multivect
|
||||
end interface
|
||||
|
||||
interface psb_gediv
|
||||
@@ -568,6 +577,18 @@ module psb_c_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in) :: flag
|
||||
end subroutine psb_cdiv_vect2_check
|
||||
subroutine psb_cdiv_trslv(x,a,desc_a,uplo,info,alpha,trans,diag)
|
||||
import :: psb_desc_type, psb_ipk_, &
|
||||
& psb_spk_, psb_c_multivect_type
|
||||
type(psb_c_multivect_type), intent (inout) :: x
|
||||
complex(psb_spk_), intent (in), dimension(:,:) :: a
|
||||
type(psb_desc_type), intent (in) :: desc_a
|
||||
character(len=1), intent(in) :: uplo
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_spk_), intent (in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans
|
||||
character(len=1), intent(in), optional :: diag
|
||||
end subroutine psb_cdiv_trslv
|
||||
end interface
|
||||
|
||||
interface psb_geinv
|
||||
|
||||
@@ -540,6 +540,15 @@ module psb_s_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=1), intent(in), optional :: conjgx, conjgy
|
||||
end subroutine psb_smlt_vect2
|
||||
subroutine psb_smlt_multivect(x, y, res, desc_a,info,global)
|
||||
import :: psb_desc_type, psb_spk_, psb_ipk_, &
|
||||
& psb_s_multivect_type, psb_sspmat_type
|
||||
real(psb_spk_), dimension(:,:), allocatable, intent(inout) :: res
|
||||
type(psb_s_multivect_type), intent(inout) :: x, y
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine psb_smlt_multivect
|
||||
end interface
|
||||
|
||||
interface psb_gediv
|
||||
@@ -579,6 +588,18 @@ module psb_s_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in) :: flag
|
||||
end subroutine psb_sdiv_vect2_check
|
||||
subroutine psb_sdiv_trslv(x,a,desc_a,uplo,info,alpha,trans,diag)
|
||||
import :: psb_desc_type, psb_ipk_, &
|
||||
& psb_spk_, psb_s_multivect_type
|
||||
type(psb_s_multivect_type), intent (inout) :: x
|
||||
real(psb_spk_), intent (in), dimension(:,:) :: a
|
||||
type(psb_desc_type), intent (in) :: desc_a
|
||||
character(len=1), intent(in) :: uplo
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
real(psb_spk_), intent (in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans
|
||||
character(len=1), intent(in), optional :: diag
|
||||
end subroutine psb_sdiv_trslv
|
||||
end interface
|
||||
|
||||
interface psb_geinv
|
||||
|
||||
@@ -529,6 +529,15 @@ module psb_z_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=1), intent(in), optional :: conjgx, conjgy
|
||||
end subroutine psb_zmlt_vect2
|
||||
subroutine psb_zmlt_multivect(x, y, res, desc_a,info,global)
|
||||
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
|
||||
& psb_z_multivect_type, psb_zspmat_type
|
||||
complex(psb_dpk_), dimension(:,:), allocatable, intent(inout) :: res
|
||||
type(psb_z_multivect_type), intent(inout) :: x, y
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine psb_zmlt_multivect
|
||||
end interface
|
||||
|
||||
interface psb_gediv
|
||||
@@ -568,6 +577,18 @@ module psb_z_psblas_mod
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
logical, intent(in) :: flag
|
||||
end subroutine psb_zdiv_vect2_check
|
||||
subroutine psb_zdiv_trslv(x,a,desc_a,uplo,info,alpha,trans,diag)
|
||||
import :: psb_desc_type, psb_ipk_, &
|
||||
& psb_dpk_, psb_z_multivect_type
|
||||
type(psb_z_multivect_type), intent (inout) :: x
|
||||
complex(psb_dpk_), intent (in), dimension(:,:) :: a
|
||||
type(psb_desc_type), intent (in) :: desc_a
|
||||
character(len=1), intent(in) :: uplo
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
complex(psb_dpk_), intent (in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans
|
||||
character(len=1), intent(in), optional :: diag
|
||||
end subroutine psb_zdiv_trslv
|
||||
end interface
|
||||
|
||||
interface psb_geinv
|
||||
|
||||
@@ -2177,13 +2177,15 @@ module psb_c_base_multivect_mod
|
||||
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(x) :: mlt_mv2 => c_base_mlv_mlt_mv2
|
||||
!!$ procedure, pass(z) :: mlt_va => c_base_mlv_mlt_va
|
||||
!!$ procedure, pass(z) :: mlt_av => c_base_mlv_mlt_av
|
||||
generic, public :: mlt => mlt_mv, mlt_mv_v, mlt_ar1, mlt_ar2, &
|
||||
& mlt_a_2, mlt_v_2 !, mlt_av, mlt_va
|
||||
& mlt_a_2, mlt_v_2, mlt_mv2 !, mlt_av, mlt_va
|
||||
!
|
||||
! Scaling and norms
|
||||
!
|
||||
procedure, pass(x) :: trslv => c_base_mlv_trslv
|
||||
procedure, pass(x) :: scal => c_base_mlv_scal
|
||||
procedure, pass(x) :: nrm2 => c_base_mlv_nrm2
|
||||
procedure, pass(x) :: amax => c_base_mlv_amax
|
||||
@@ -2672,6 +2674,70 @@ contains
|
||||
res(1:m,1:n) = x%v(1:m,1:n)
|
||||
end function c_base_mlv_get_vect
|
||||
|
||||
!
|
||||
!> subroutine d_base_mlv_trslv
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief Computes X = X / A with A an upper triangular matrix
|
||||
!! \param n Number of entries to be considered
|
||||
!! \param x The multivector to be used for the division
|
||||
!! \param uplo 'U' for upper triangular, 'L' for lower triangular
|
||||
!! \param a The matrix to be used for the division
|
||||
!! \param alpha (optional) The scaling factor
|
||||
!! \param trans (optional) 'N' for no transpose, 'T' for transpose
|
||||
!! \param diag (optional) 'N' for non-unit diagonal, 'U' for unit diagonal
|
||||
!! \param info return code
|
||||
!!
|
||||
subroutine c_base_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_c_base_multivect_type), intent(inout) :: x
|
||||
complex(psb_spk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
complex(psb_spk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: lda, ldb
|
||||
character(len=1) :: trans_, diag_, side
|
||||
complex(psb_spk_) :: alpha_
|
||||
|
||||
! Default values
|
||||
if (.not.present(alpha)) then
|
||||
alpha_ = cone
|
||||
else
|
||||
alpha_ = alpha
|
||||
end if
|
||||
if (.not.present(trans)) then
|
||||
trans_ = 'N'
|
||||
else
|
||||
trans_ = trans
|
||||
end if
|
||||
if (.not.present(diag)) then
|
||||
diag_ = 'N'
|
||||
else
|
||||
diag_ = diag
|
||||
end if
|
||||
|
||||
info = psb_success_
|
||||
! Check that a is square
|
||||
if (size(a,1) /= size(a,2)) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
! Check that a has the same number of columns as x
|
||||
if (size(a,2) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (x%is_sync()) then
|
||||
! Call BLAS function to solve the system
|
||||
lda = size(a,1)
|
||||
ldb = x%get_nrows()
|
||||
side = 'R' ! X*op( A ) = alpha*B.
|
||||
call dtrsm(side, uplo, trans_, diag_, n, x%get_ncols(), alpha_, a, lda, x%v, ldb)
|
||||
end if
|
||||
end subroutine c_base_mlv_trslv
|
||||
!
|
||||
! Reset all values
|
||||
!
|
||||
@@ -2886,6 +2952,48 @@ contains
|
||||
|
||||
end subroutine c_base_mlv_axpby_a
|
||||
|
||||
!> Function base_mlv_mlt_mv2
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief computes A = transpose(X)*Y / conjugatetranspose(X)*Y
|
||||
!! \param x The class(base_mlv_vect) to be multiplied by
|
||||
!! \param y The class(base_mlv_vect) to be multiplied by
|
||||
!! \param a The resulting matrix
|
||||
!! \param info return code
|
||||
subroutine c_base_mlv_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_c_base_multivect_type), intent(inout) :: x
|
||||
class(psb_c_base_multivect_type), intent(inout) :: y
|
||||
complex(psb_spk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (y%is_dev()) call y%sync()
|
||||
|
||||
if (allocated(a)) then
|
||||
if (size(a,1) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (size(a,2) /= y%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
else
|
||||
allocate(a(x%get_ncols(),y%get_ncols()),stat=info)
|
||||
if (info /= 0) call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_mlt_mv2')
|
||||
end if
|
||||
! We do the multiplication by using the BLAS function
|
||||
! dgemm, which computes the matrix-matrix product
|
||||
! C = alpha*op( A )*op( B ) + beta*C
|
||||
! In our case, we want to compute
|
||||
! C = X'*Y
|
||||
call dgemm('C', 'N', x%get_ncols(), y%get_ncols(), n, cone, &
|
||||
& x%v, x%get_nrows(), y%v, y%get_nrows(), czero, a, x%get_ncols())
|
||||
|
||||
end subroutine c_base_mlv_mlt_mv2
|
||||
|
||||
!
|
||||
! Multiple variants of two operations:
|
||||
|
||||
@@ -1344,6 +1344,9 @@ module psb_c_multivect_mod
|
||||
procedure, pass(x) :: dot_a => c_mvect_dot_a
|
||||
procedure, pass(x) :: dot_a_vect => c_mvect_dot_vect
|
||||
generic, public :: dot => dot_v, dot_a, dot_a_vect
|
||||
procedure, pass(x) :: trslv => c_mlv_trslv
|
||||
procedure, pass(x) :: mlt_mv2 => c_mvect_mlt_mv2
|
||||
generic, public :: mlt => mlt_mv2
|
||||
!!$ procedure, pass(y) :: axpby_v => c_mvect_axpby_v
|
||||
!!$ procedure, pass(y) :: axpby_a => c_mvect_axpby_a
|
||||
!!$ generic, public :: axpby => axpby_v, axpby_a
|
||||
@@ -1876,6 +1879,43 @@ contains
|
||||
|
||||
end function c_mvect_dot_a
|
||||
|
||||
subroutine c_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_c_multivect_type), intent(inout) :: x
|
||||
complex(psb_spk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
complex(psb_spk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (.not.allocated(x%v)) then
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
else
|
||||
call x%v%trslv(n,a,uplo,alpha=alpha,trans=trans,diag=diag,info=info)
|
||||
end if
|
||||
end subroutine c_mlv_trslv
|
||||
|
||||
subroutine c_mvect_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_c_multivect_type), intent(inout) :: x
|
||||
class(psb_c_multivect_type), intent(inout) :: y
|
||||
complex(psb_spk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (allocated(x%v).and.allocated(y%v)) then
|
||||
call y%v%mlt(n,x%v,a,info)
|
||||
else
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine c_mvect_mlt_mv2
|
||||
|
||||
|
||||
!!$ subroutine c_mvect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
|
||||
@@ -2917,8 +2917,6 @@ contains
|
||||
call dtrsm(side, uplo, trans_, diag_, n, x%get_ncols(), alpha_, a, lda, x%v, ldb)
|
||||
end if
|
||||
end subroutine d_base_mlv_trslv
|
||||
|
||||
|
||||
!
|
||||
! Reset all values
|
||||
!
|
||||
@@ -3133,10 +3131,9 @@ contains
|
||||
|
||||
end subroutine d_base_mlv_axpby_a
|
||||
|
||||
|
||||
!> Function base_mlv_mlt_mv2
|
||||
!> Function base_mlv_mlt_mv2
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief computes A = transpose(X)*Y
|
||||
!! \brief computes A = transpose(X)*Y / conjugatetranspose(X)*Y
|
||||
!! \param x The class(base_mlv_vect) to be multiplied by
|
||||
!! \param y The class(base_mlv_vect) to be multiplied by
|
||||
!! \param a The resulting matrix
|
||||
@@ -3172,13 +3169,11 @@ contains
|
||||
! C = alpha*op( A )*op( B ) + beta*C
|
||||
! In our case, we want to compute
|
||||
! C = X'*Y
|
||||
call dgemm('T', 'N', x%get_ncols(), y%get_ncols(), n, done, &
|
||||
call dgemm('C', 'N', x%get_ncols(), y%get_ncols(), n, done, &
|
||||
& x%v, x%get_nrows(), y%v, y%get_nrows(), dzero, a, x%get_ncols())
|
||||
|
||||
end subroutine d_base_mlv_mlt_mv2
|
||||
|
||||
|
||||
|
||||
!
|
||||
! Multiple variants of two operations:
|
||||
! Simple multiplication Y(:.:) = X(:,:)*Y(:,:)
|
||||
|
||||
@@ -1994,6 +1994,7 @@ contains
|
||||
|
||||
end subroutine d_mvect_mlt_mv2
|
||||
|
||||
|
||||
!!$ subroutine d_mvect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
|
||||
@@ -2356,13 +2356,15 @@ module psb_s_base_multivect_mod
|
||||
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(x) :: mlt_mv2 => s_base_mlv_mlt_mv2
|
||||
!!$ procedure, pass(z) :: mlt_va => s_base_mlv_mlt_va
|
||||
!!$ procedure, pass(z) :: mlt_av => s_base_mlv_mlt_av
|
||||
generic, public :: mlt => mlt_mv, mlt_mv_v, mlt_ar1, mlt_ar2, &
|
||||
& mlt_a_2, mlt_v_2 !, mlt_av, mlt_va
|
||||
& mlt_a_2, mlt_v_2, mlt_mv2 !, mlt_av, mlt_va
|
||||
!
|
||||
! Scaling and norms
|
||||
!
|
||||
procedure, pass(x) :: trslv => s_base_mlv_trslv
|
||||
procedure, pass(x) :: scal => s_base_mlv_scal
|
||||
procedure, pass(x) :: nrm2 => s_base_mlv_nrm2
|
||||
procedure, pass(x) :: amax => s_base_mlv_amax
|
||||
@@ -2851,6 +2853,70 @@ contains
|
||||
res(1:m,1:n) = x%v(1:m,1:n)
|
||||
end function s_base_mlv_get_vect
|
||||
|
||||
!
|
||||
!> subroutine d_base_mlv_trslv
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief Computes X = X / A with A an upper triangular matrix
|
||||
!! \param n Number of entries to be considered
|
||||
!! \param x The multivector to be used for the division
|
||||
!! \param uplo 'U' for upper triangular, 'L' for lower triangular
|
||||
!! \param a The matrix to be used for the division
|
||||
!! \param alpha (optional) The scaling factor
|
||||
!! \param trans (optional) 'N' for no transpose, 'T' for transpose
|
||||
!! \param diag (optional) 'N' for non-unit diagonal, 'U' for unit diagonal
|
||||
!! \param info return code
|
||||
!!
|
||||
subroutine s_base_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_s_base_multivect_type), intent(inout) :: x
|
||||
real(psb_spk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
real(psb_spk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: lda, ldb
|
||||
character(len=1) :: trans_, diag_, side
|
||||
real(psb_spk_) :: alpha_
|
||||
|
||||
! Default values
|
||||
if (.not.present(alpha)) then
|
||||
alpha_ = sone
|
||||
else
|
||||
alpha_ = alpha
|
||||
end if
|
||||
if (.not.present(trans)) then
|
||||
trans_ = 'N'
|
||||
else
|
||||
trans_ = trans
|
||||
end if
|
||||
if (.not.present(diag)) then
|
||||
diag_ = 'N'
|
||||
else
|
||||
diag_ = diag
|
||||
end if
|
||||
|
||||
info = psb_success_
|
||||
! Check that a is square
|
||||
if (size(a,1) /= size(a,2)) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
! Check that a has the same number of columns as x
|
||||
if (size(a,2) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (x%is_sync()) then
|
||||
! Call BLAS function to solve the system
|
||||
lda = size(a,1)
|
||||
ldb = x%get_nrows()
|
||||
side = 'R' ! X*op( A ) = alpha*B.
|
||||
call dtrsm(side, uplo, trans_, diag_, n, x%get_ncols(), alpha_, a, lda, x%v, ldb)
|
||||
end if
|
||||
end subroutine s_base_mlv_trslv
|
||||
!
|
||||
! Reset all values
|
||||
!
|
||||
@@ -3065,6 +3131,48 @@ contains
|
||||
|
||||
end subroutine s_base_mlv_axpby_a
|
||||
|
||||
!> Function base_mlv_mlt_mv2
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief computes A = transpose(X)*Y / conjugatetranspose(X)*Y
|
||||
!! \param x The class(base_mlv_vect) to be multiplied by
|
||||
!! \param y The class(base_mlv_vect) to be multiplied by
|
||||
!! \param a The resulting matrix
|
||||
!! \param info return code
|
||||
subroutine s_base_mlv_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_s_base_multivect_type), intent(inout) :: x
|
||||
class(psb_s_base_multivect_type), intent(inout) :: y
|
||||
real(psb_spk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (y%is_dev()) call y%sync()
|
||||
|
||||
if (allocated(a)) then
|
||||
if (size(a,1) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (size(a,2) /= y%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
else
|
||||
allocate(a(x%get_ncols(),y%get_ncols()),stat=info)
|
||||
if (info /= 0) call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_mlt_mv2')
|
||||
end if
|
||||
! We do the multiplication by using the BLAS function
|
||||
! dgemm, which computes the matrix-matrix product
|
||||
! C = alpha*op( A )*op( B ) + beta*C
|
||||
! In our case, we want to compute
|
||||
! C = X'*Y
|
||||
call dgemm('C', 'N', x%get_ncols(), y%get_ncols(), n, sone, &
|
||||
& x%v, x%get_nrows(), y%v, y%get_nrows(), szero, a, x%get_ncols())
|
||||
|
||||
end subroutine s_base_mlv_mlt_mv2
|
||||
|
||||
!
|
||||
! Multiple variants of two operations:
|
||||
|
||||
@@ -1423,6 +1423,9 @@ module psb_s_multivect_mod
|
||||
procedure, pass(x) :: dot_a => s_mvect_dot_a
|
||||
procedure, pass(x) :: dot_a_vect => s_mvect_dot_vect
|
||||
generic, public :: dot => dot_v, dot_a, dot_a_vect
|
||||
procedure, pass(x) :: trslv => s_mlv_trslv
|
||||
procedure, pass(x) :: mlt_mv2 => s_mvect_mlt_mv2
|
||||
generic, public :: mlt => mlt_mv2
|
||||
!!$ procedure, pass(y) :: axpby_v => s_mvect_axpby_v
|
||||
!!$ procedure, pass(y) :: axpby_a => s_mvect_axpby_a
|
||||
!!$ generic, public :: axpby => axpby_v, axpby_a
|
||||
@@ -1955,6 +1958,43 @@ contains
|
||||
|
||||
end function s_mvect_dot_a
|
||||
|
||||
subroutine s_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_s_multivect_type), intent(inout) :: x
|
||||
real(psb_spk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
real(psb_spk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (.not.allocated(x%v)) then
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
else
|
||||
call x%v%trslv(n,a,uplo,alpha=alpha,trans=trans,diag=diag,info=info)
|
||||
end if
|
||||
end subroutine s_mlv_trslv
|
||||
|
||||
subroutine s_mvect_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_s_multivect_type), intent(inout) :: x
|
||||
class(psb_s_multivect_type), intent(inout) :: y
|
||||
real(psb_spk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (allocated(x%v).and.allocated(y%v)) then
|
||||
call y%v%mlt(n,x%v,a,info)
|
||||
else
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine s_mvect_mlt_mv2
|
||||
|
||||
|
||||
!!$ subroutine s_mvect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
|
||||
@@ -2177,13 +2177,15 @@ module psb_z_base_multivect_mod
|
||||
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(x) :: mlt_mv2 => z_base_mlv_mlt_mv2
|
||||
!!$ procedure, pass(z) :: mlt_va => z_base_mlv_mlt_va
|
||||
!!$ procedure, pass(z) :: mlt_av => z_base_mlv_mlt_av
|
||||
generic, public :: mlt => mlt_mv, mlt_mv_v, mlt_ar1, mlt_ar2, &
|
||||
& mlt_a_2, mlt_v_2 !, mlt_av, mlt_va
|
||||
& mlt_a_2, mlt_v_2, mlt_mv2 !, mlt_av, mlt_va
|
||||
!
|
||||
! Scaling and norms
|
||||
!
|
||||
procedure, pass(x) :: trslv => z_base_mlv_trslv
|
||||
procedure, pass(x) :: scal => z_base_mlv_scal
|
||||
procedure, pass(x) :: nrm2 => z_base_mlv_nrm2
|
||||
procedure, pass(x) :: amax => z_base_mlv_amax
|
||||
@@ -2672,6 +2674,70 @@ contains
|
||||
res(1:m,1:n) = x%v(1:m,1:n)
|
||||
end function z_base_mlv_get_vect
|
||||
|
||||
!
|
||||
!> subroutine d_base_mlv_trslv
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief Computes X = X / A with A an upper triangular matrix
|
||||
!! \param n Number of entries to be considered
|
||||
!! \param x The multivector to be used for the division
|
||||
!! \param uplo 'U' for upper triangular, 'L' for lower triangular
|
||||
!! \param a The matrix to be used for the division
|
||||
!! \param alpha (optional) The scaling factor
|
||||
!! \param trans (optional) 'N' for no transpose, 'T' for transpose
|
||||
!! \param diag (optional) 'N' for non-unit diagonal, 'U' for unit diagonal
|
||||
!! \param info return code
|
||||
!!
|
||||
subroutine z_base_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_z_base_multivect_type), intent(inout) :: x
|
||||
complex(psb_dpk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
complex(psb_dpk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: lda, ldb
|
||||
character(len=1) :: trans_, diag_, side
|
||||
complex(psb_dpk_) :: alpha_
|
||||
|
||||
! Default values
|
||||
if (.not.present(alpha)) then
|
||||
alpha_ = zone
|
||||
else
|
||||
alpha_ = alpha
|
||||
end if
|
||||
if (.not.present(trans)) then
|
||||
trans_ = 'N'
|
||||
else
|
||||
trans_ = trans
|
||||
end if
|
||||
if (.not.present(diag)) then
|
||||
diag_ = 'N'
|
||||
else
|
||||
diag_ = diag
|
||||
end if
|
||||
|
||||
info = psb_success_
|
||||
! Check that a is square
|
||||
if (size(a,1) /= size(a,2)) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
! Check that a has the same number of columns as x
|
||||
if (size(a,2) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (x%is_sync()) then
|
||||
! Call BLAS function to solve the system
|
||||
lda = size(a,1)
|
||||
ldb = x%get_nrows()
|
||||
side = 'R' ! X*op( A ) = alpha*B.
|
||||
call dtrsm(side, uplo, trans_, diag_, n, x%get_ncols(), alpha_, a, lda, x%v, ldb)
|
||||
end if
|
||||
end subroutine z_base_mlv_trslv
|
||||
!
|
||||
! Reset all values
|
||||
!
|
||||
@@ -2886,6 +2952,48 @@ contains
|
||||
|
||||
end subroutine z_base_mlv_axpby_a
|
||||
|
||||
!> Function base_mlv_mlt_mv2
|
||||
!! \memberof psb_d_base_multivect_type
|
||||
!! \brief computes A = transpose(X)*Y / conjugatetranspose(X)*Y
|
||||
!! \param x The class(base_mlv_vect) to be multiplied by
|
||||
!! \param y The class(base_mlv_vect) to be multiplied by
|
||||
!! \param a The resulting matrix
|
||||
!! \param info return code
|
||||
subroutine z_base_mlv_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_z_base_multivect_type), intent(inout) :: x
|
||||
class(psb_z_base_multivect_type), intent(inout) :: y
|
||||
complex(psb_dpk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = psb_success_
|
||||
if (x%is_dev()) call x%sync()
|
||||
if (y%is_dev()) call y%sync()
|
||||
|
||||
if (allocated(a)) then
|
||||
if (size(a,1) /= x%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
if (size(a,2) /= y%get_ncols()) then
|
||||
info = psb_err_invalid_input_
|
||||
return
|
||||
end if
|
||||
else
|
||||
allocate(a(x%get_ncols(),y%get_ncols()),stat=info)
|
||||
if (info /= 0) call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_mlt_mv2')
|
||||
end if
|
||||
! We do the multiplication by using the BLAS function
|
||||
! dgemm, which computes the matrix-matrix product
|
||||
! C = alpha*op( A )*op( B ) + beta*C
|
||||
! In our case, we want to compute
|
||||
! C = X'*Y
|
||||
call dgemm('C', 'N', x%get_ncols(), y%get_ncols(), n, zone, &
|
||||
& x%v, x%get_nrows(), y%v, y%get_nrows(), zzero, a, x%get_ncols())
|
||||
|
||||
end subroutine z_base_mlv_mlt_mv2
|
||||
|
||||
!
|
||||
! Multiple variants of two operations:
|
||||
|
||||
@@ -1344,6 +1344,9 @@ module psb_z_multivect_mod
|
||||
procedure, pass(x) :: dot_a => z_mvect_dot_a
|
||||
procedure, pass(x) :: dot_a_vect => z_mvect_dot_vect
|
||||
generic, public :: dot => dot_v, dot_a, dot_a_vect
|
||||
procedure, pass(x) :: trslv => z_mlv_trslv
|
||||
procedure, pass(x) :: mlt_mv2 => z_mvect_mlt_mv2
|
||||
generic, public :: mlt => mlt_mv2
|
||||
!!$ procedure, pass(y) :: axpby_v => z_mvect_axpby_v
|
||||
!!$ procedure, pass(y) :: axpby_a => z_mvect_axpby_a
|
||||
!!$ generic, public :: axpby => axpby_v, axpby_a
|
||||
@@ -1876,6 +1879,43 @@ contains
|
||||
|
||||
end function z_mvect_dot_a
|
||||
|
||||
subroutine z_mlv_trslv(n,x,a,uplo,alpha,trans,diag,info)
|
||||
implicit none
|
||||
class(psb_z_multivect_type), intent(inout) :: x
|
||||
complex(psb_dpk_), intent(in) :: a(:,:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
character(len=1), intent(in) :: uplo
|
||||
complex(psb_dpk_), intent(in), optional :: alpha
|
||||
character(len=1), intent(in), optional :: trans, diag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (.not.allocated(x%v)) then
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
else
|
||||
call x%v%trslv(n,a,uplo,alpha=alpha,trans=trans,diag=diag,info=info)
|
||||
end if
|
||||
end subroutine z_mlv_trslv
|
||||
|
||||
subroutine z_mvect_mlt_mv2(n,x,y,a,info)
|
||||
use psi_serial_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
class(psb_z_multivect_type), intent(inout) :: x
|
||||
class(psb_z_multivect_type), intent(inout) :: y
|
||||
complex(psb_dpk_), intent(inout), allocatable :: a(:,:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
if (allocated(x%v).and.allocated(y%v)) then
|
||||
call y%v%mlt(n,x%v,a,info)
|
||||
else
|
||||
info = psb_err_invalid_vect_state_
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine z_mvect_mlt_mv2
|
||||
|
||||
|
||||
!!$ subroutine z_mvect_axpby_v(m,alpha, x, beta, y, info)
|
||||
!!$ use psi_serial_mod
|
||||
!!$ implicit none
|
||||
|
||||
Reference in New Issue
Block a user