#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_sym
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_ssygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info )
!! SSYGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 3_${ik}$*n - 1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 2_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_spotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_ssygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_ssyev( jobz, uplo, n, a, lda, w, work, lwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssygv
module subroutine stdlib${ii}$_dsygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info )
!! DSYGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 3_${ik}$*n - 1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 2_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_dpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dsygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_dsyev( jobz, uplo, n, a, lda, w, work, lwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsygv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info )
!! DSYGV: computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 3_${ik}$*n - 1_${ik}$ )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 2_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ri}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ri}$syev( jobz, uplo, n, a, lda, w, work, lwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sygv
#:endif
#:endfor
module subroutine stdlib${ii}$_ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,&
!! SSYGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n + 1_${ik}$
end if
lopt = lwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_spotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_ssygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork,info )
lopt = max( real( lopt,KIND=sp), real( work( 1_${ik}$ ),KIND=sp) )
liopt = max( real( liopt,KIND=sp), real( iwork( 1_${ik}$ ),KIND=sp) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_ssygvd
module subroutine stdlib${ii}$_dsygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,&
!! DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n + 1_${ik}$
end if
lopt = lwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_dpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dsygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_dsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork,info )
lopt = max( real( lopt,KIND=dp), real( work( 1_${ik}$ ),KIND=dp) )
liopt = max( real( liopt,KIND=dp), real( iwork( 1_${ik}$ ),KIND=dp) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_dsygvd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,&
!! DSYGVD: computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n + 1_${ik}$
end if
lopt = lwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ri}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ri}$syevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork,info )
lopt = max( real( lopt,KIND=${rk}$), real( work( 1_${ik}$ ),KIND=${rk}$) )
liopt = max( real( liopt,KIND=${rk}$), real( iwork( 1_${ik}$ ),KIND=${rk}$) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_${ri}$sygvd
#:endif
#:endfor
module subroutine stdlib${ii}$_ssygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! SSYGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(inout) :: a(lda,*), b(ldb,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 8_${ik}$*n )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_spotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_ssygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_ssyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssygvx
module subroutine stdlib${ii}$_dsygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! DSYGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(inout) :: a(lda,*), b(ldb,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 8_${ik}$*n )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_dpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dsygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_dsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsygvx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! DSYGVX: computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${rk}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkmin, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
lwkmin = max( 1_${ik}$, 8_${ik}$*n )
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<lwkmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_${ri}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ri}$syevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
call stdlib${ii}$_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
call stdlib${ii}$_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sygvx
#:endif
#:endfor
module subroutine stdlib${ii}$_sspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info )
!! SSPGV computes all the eigenvalues and, optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(sp), intent(inout) :: ap(*), bp(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_spptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_sspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_sspev( jobz, uplo, n, ap, w, z, ldz, work, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_sspgv
module subroutine stdlib${ii}$_dspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info )
!! DSPGV computes all the eigenvalues and, optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(dp), intent(inout) :: ap(*), bp(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_dpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_dspev( jobz, uplo, n, ap, w, z, ldz, work, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_dspgv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info )
!! DSPGV: computes all the eigenvalues and, optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be symmetric, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: ap(*), bp(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ri}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$spgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ri}$spev( jobz, uplo, n, ap, w, z, ldz, work, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_${ri}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_${ri}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$spgv
#:endif
#:endfor
module subroutine stdlib${ii}$_sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,&
!! SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: ap(*), bp(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else
if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of bp.
call stdlib${ii}$_spptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_sspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork,liwork, info )
lwmin = max( real( lwmin,KIND=sp), real( work( 1_${ik}$ ),KIND=sp) )
liwmin = max( real( liwmin,KIND=sp), real( iwork( 1_${ik}$ ),KIND=sp) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t *y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sspgvd
module subroutine stdlib${ii}$_dspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,&
!! DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: ap(*), bp(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else
if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of bp.
call stdlib${ii}$_dpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_dspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork,liwork, info )
lwmin = max( real( lwmin,KIND=dp), real( work( 1_${ik}$ ),KIND=dp) )
liwmin = max( real( liwmin,KIND=dp), real( iwork( 1_${ik}$ ),KIND=dp) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t *y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dspgvd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,&
!! DSPGVD: computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be symmetric, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: ap(*), bp(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else
if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of bp.
call stdlib${ii}$_${ri}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$spgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ri}$spevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork,liwork, info )
lwmin = max( real( lwmin,KIND=${rk}$), real( work( 1_${ik}$ ),KIND=${rk}$) )
liwmin = max( real( liwmin,KIND=${rk}$), real( iwork( 1_${ik}$ ),KIND=${rk}$) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, neig
call stdlib${ii}$_${ri}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t *y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_${ri}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$spgvd
#:endif
#:endfor
module subroutine stdlib${ii}$_sspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! SSPGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric, stored in packed storage, and B
!! is also positive definite. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
z, ldz, work, iwork,ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(inout) :: ap(*), bp(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_spptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_sspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, m
call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_sspgvx
module subroutine stdlib${ii}$_dspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! DSPGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric, stored in packed storage, and B
!! is also positive definite. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
z, ldz, work, iwork,ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(inout) :: ap(*), bp(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_dpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_dspgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_dspevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, m
call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_dspgvx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! DSPGVX: computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
!! and B are assumed to be symmetric, stored in packed storage, and B
!! is also positive definite. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
z, ldz, work, iwork,ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(${rk}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${rk}$), intent(inout) :: ap(*), bp(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
upper = stdlib_lsame( uplo, 'U' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ri}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ri}$spgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ri}$spevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'T'
end if
do j = 1, m
call stdlib${ii}$_${ri}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**t*y
if( upper ) then
trans = 'T'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_${ri}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ri}$spgvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! SSBGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_spbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work( indwrk ), &
iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_ssbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_ssteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( inde ), info )
else
call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info )
end if
return
end subroutine stdlib${ii}$_ssbgv
pure module subroutine stdlib${ii}$_dsbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! DSBGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_dpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_dsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work( indwrk ), &
iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_dsbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_ssteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( inde ), info )
else
call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info )
end if
return
end subroutine stdlib${ii}$_dsbgv
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! DSBGV: computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite.
info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ri}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work( indwrk ), &
iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, call stdlib${ii}$_dsteqr.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( inde ), info )
else
call stdlib${ii}$_${ri}$steqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info )
end if
return
end subroutine stdlib${ii}$_${ri}$sbgv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! SSBGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of the
!! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
!! banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_spbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_ssbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_sstedc.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( inde ), info )
else
call stdlib${ii}$_sstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), &
llwrk2, iwork, liwork, info )
call stdlib${ii}$_sgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( &
indwk2 ), n )
call stdlib${ii}$_slacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_ssbgvd
pure module subroutine stdlib${ii}$_dsbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of the
!! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
!! banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_dpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_dsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_dsbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_sstedc.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( inde ), info )
else
call stdlib${ii}$_dstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), &
llwrk2, iwork, liwork, info )
call stdlib${ii}$_dgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( &
indwk2 ), n )
call stdlib${ii}$_dlacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dsbgvd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! DSBGVD: computes all the eigenvalues, and optionally, the eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of the
!! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
!! banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( wantz ) then
liwmin = 3_${ik}$ + 5_${ik}$*n
lwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ri}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )&
, iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, call stdlib${ii}$_dstedc.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( inde ), info )
else
call stdlib${ii}$_${ri}$stedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), &
llwrk2, iwork, liwork, info )
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( &
indwk2 ), n )
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$sbgvd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! SSBGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(sp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwo, indwrk, itmp1, j, &
jj, nsplit
real(sp) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_spbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, iinfo )
! reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_ssbtrd( vect, uplo, n, ka, ab, ldab, work( indd ),work( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_ssteqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_sstebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indwrk + 2_${ik}$*n
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( indee ), info )
else
call stdlib${ii}$_slacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired,
! call stdlib${ii}$_sstein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_sstebz( range, order, n, vl, vu, il, iu, abstol,work( indd ), work( inde ),&
m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info )
! apply transformation matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_sstein.
do j = 1, m
call stdlib${ii}$_scopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_sgemv( 'N', n, n, one, q, ldq, work, 1_${ik}$, zero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_ssbgvx
pure module subroutine stdlib${ii}$_dsbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! DSBGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(dp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwo, indwrk, itmp1, j, &
jj, nsplit
real(dp) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_dpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_dsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, iinfo )
! reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_dsbtrd( vect, uplo, n, ka, ab, ldab, work( indd ),work( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_ssteqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_dstebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indwrk + 2_${ik}$*n
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( indee ), info )
else
call stdlib${ii}$_dlacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired,
! call stdlib${ii}$_dstein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_dstebz( range, order, n, vl, vu, il, iu, abstol,work( indd ), work( inde ),&
m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info )
! apply transformation matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_dstein.
do j = 1, m
call stdlib${ii}$_dcopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_dgemv( 'N', n, n, one, q, ldq, work, 1_${ik}$, zero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_dsbgvx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! DSBGVX: computes selected eigenvalues, and optionally, eigenvectors
!! of a real generalized symmetric-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(${rk}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
real(${rk}$), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwo, indwrk, itmp1, j, &
jj, nsplit
real(${rk}$) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ri}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, iinfo )
! reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, work( indd ),work( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_${ri}$sterf or stdlib${ii}$_dsteqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_${ri}$stebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_${ri}$copy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indwrk + 2_${ik}$*n
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( indee ), info )
else
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_${ri}$steqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${ri}$stebz and, if eigenvectors are desired,
! call stdlib${ii}$_${ri}$stein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_${ri}$stebz( range, order, n, vl, vu, il, iu, abstol,work( indd ), work( inde ),&
m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info )
! apply transformation matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ri}$stein.
do j = 1, m
call stdlib${ii}$_${ri}$copy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ri}$gemv( 'N', n, n, one, q, ldq, work, 1_${ik}$, zero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_${ri}$sbgvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! SSYTRD reduces a real symmetric matrix A to real symmetric
!! tridiagonal form T by an orthogonal similarity transformation:
!! Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: d(*), e(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_slatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_ssyr2k( uplo, 'NO TRANSPOSE', i-1, nb, -one, a( 1_${ik}$, i ),lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_ssytd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_slatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+ib:n,i+ib:n), using
! an update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_ssyr2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -one,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_ssytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssytrd
pure module subroutine stdlib${ii}$_dsytrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! DSYTRD reduces a real symmetric matrix A to real symmetric
!! tridiagonal form T by an orthogonal similarity transformation:
!! Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: d(*), e(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_dlatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_dsyr2k( uplo, 'NO TRANSPOSE', i-1, nb, -one, a( 1_${ik}$, i ),lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_dsytd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_dlatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+ib:n,i+ib:n), using
! an update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_dsyr2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -one,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_dsytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsytrd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! DSYTRD: reduces a real symmetric matrix A to real symmetric
!! tridiagonal form T by an orthogonal similarity transformation:
!! Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: d(*), e(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_${ri}$latrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_${ri}$syr2k( uplo, 'NO TRANSPOSE', i-1, nb, -one, a( 1_${ik}$, i ),lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_${ri}$sytd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_${ri}$latrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+ib:n,i+ib:n), using
! an update of the form: a := a - v*w**t - w*v**t
call stdlib${ii}$_${ri}$syr2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -one,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = a( j, j )
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_${ri}$sytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$sytrd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssytd2( uplo, n, a, lda, d, e, tau, info )
!! SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
!! form T by an orthogonal similarity transformation: Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: d(*), e(*), tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(sp) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(1:i-1,i+1)
call stdlib${ii}$_slarfg( i, a( i, i+1 ), a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = a( i, i+1 )
if( taui/=zero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = one
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_ssymv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, zero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_sdot( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_saxpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_ssyr2( uplo, i, -one, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
a( i, i+1 ) = e( i )
end if
d( i+1 ) = a( i+1, i+1 )
tau( i ) = taui
end do
d( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
! reduce the lower triangle of a
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(i+2:n,i)
call stdlib${ii}$_slarfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,taui )
e( i ) = a( i+1, i )
if( taui/=zero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = one
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_ssymv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, zero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_sdot( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_saxpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_ssyr2( uplo, n-i, -one, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 ),&
lda )
a( i+1, i ) = e( i )
end if
d( i ) = a( i, i )
tau( i ) = taui
end do
d( n ) = a( n, n )
end if
return
end subroutine stdlib${ii}$_ssytd2
pure module subroutine stdlib${ii}$_dsytd2( uplo, n, a, lda, d, e, tau, info )
!! DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
!! form T by an orthogonal similarity transformation: Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: d(*), e(*), tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(dp) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(1:i-1,i+1)
call stdlib${ii}$_dlarfg( i, a( i, i+1 ), a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = a( i, i+1 )
if( taui/=zero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = one
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_dsymv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, zero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_ddot( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_daxpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_dsyr2( uplo, i, -one, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
a( i, i+1 ) = e( i )
end if
d( i+1 ) = a( i+1, i+1 )
tau( i ) = taui
end do
d( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
! reduce the lower triangle of a
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(i+2:n,i)
call stdlib${ii}$_dlarfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,taui )
e( i ) = a( i+1, i )
if( taui/=zero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = one
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_dsymv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, zero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_ddot( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_daxpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_dsyr2( uplo, n-i, -one, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 ),&
lda )
a( i+1, i ) = e( i )
end if
d( i ) = a( i, i )
tau( i ) = taui
end do
d( n ) = a( n, n )
end if
return
end subroutine stdlib${ii}$_dsytd2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sytd2( uplo, n, a, lda, d, e, tau, info )
!! DSYTD2: reduces a real symmetric matrix A to symmetric tridiagonal
!! form T by an orthogonal similarity transformation: Q**T * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: d(*), e(*), tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
real(${rk}$) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(1:i-1,i+1)
call stdlib${ii}$_${ri}$larfg( i, a( i, i+1 ), a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = a( i, i+1 )
if( taui/=zero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = one
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_${ri}$symv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, zero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_${ri}$dot( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_${ri}$syr2( uplo, i, -one, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
a( i, i+1 ) = e( i )
end if
d( i+1 ) = a( i+1, i+1 )
tau( i ) = taui
end do
d( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
! reduce the lower triangle of a
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**t
! to annihilate a(i+2:n,i)
call stdlib${ii}$_${ri}$larfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1_${ik}$,taui )
e( i ) = a( i+1, i )
if( taui/=zero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = one
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_${ri}$symv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, zero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**t * v) * v
alpha = -half*taui*stdlib${ii}$_${ri}$dot( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**t - w * v**t
call stdlib${ii}$_${ri}$syr2( uplo, n-i, -one, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 ),&
lda )
a( i+1, i ) = e( i )
end if
d( i ) = a( i, i )
tau( i ) = taui
end do
d( n ) = a( n, n )
end if
return
end subroutine stdlib${ii}$_${ri}$sytd2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sorgtr( uplo, n, a, lda, tau, work, lwork, info )
!! SORGTR generates a real orthogonal matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! SSYTRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if ( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_ssytrd with uplo = 'u'
! shift the vectors which define the elementary reflectors one
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = zero
end do
do i = 1, n - 1
a( i, n ) = zero
end do
a( n, n ) = one
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_sorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_ssytrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = zero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = one
do i = 2, n
a( i, 1_${ik}$ ) = zero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_sorgqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sorgtr
pure module subroutine stdlib${ii}$_dorgtr( uplo, n, a, lda, tau, work, lwork, info )
!! DORGTR generates a real orthogonal matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! DSYTRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_dsytrd with uplo = 'u'
! shift the vectors which define the elementary reflectors one
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = zero
end do
do i = 1, n - 1
a( i, n ) = zero
end do
a( n, n ) = one
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_dorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_dsytrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = zero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = one
do i = 2, n
a( i, 1_${ik}$ ) = zero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_dorgqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dorgtr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$orgtr( uplo, n, a, lda, tau, work, lwork, info )
!! DORGTR: generates a real orthogonal matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! DSYTRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_${ri}$sytrd with uplo = 'u'
! shift the vectors which define the elementary reflectors one
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = zero
end do
do i = 1, n - 1
a( i, n ) = zero
end do
a( n, n ) = one
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_${ri}$orgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_${ri}$sytrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors one
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = zero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = one
do i = 2, n
a( i, 1_${ik}$ ) = zero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_${ri}$orgqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$orgtr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! SORMTR overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by SSYTRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*), c(ldc,*)
real(sp), intent(in) :: tau(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, ni, nb, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SORMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_ssytrd with uplo = 'u'
call stdlib${ii}$_sormql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_ssytrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_sormqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_sormtr
pure module subroutine stdlib${ii}$_dormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! DORMTR overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by DSYTRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*), c(ldc,*)
real(dp), intent(in) :: tau(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_dsytrd with uplo = 'u'
call stdlib${ii}$_dormql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_dsytrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_dormqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dormtr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$ormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! DORMTR: overwrites the general real M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'T': Q**T * C C * Q**T
!! where Q is a real orthogonal matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by DSYTRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*)
real(${rk}$), intent(in) :: tau(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DORMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_${ri}$sytrd with uplo = 'u'
call stdlib${ii}$_${ri}$ormql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_${ri}$sytrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_${ri}$ormqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$ormtr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! SSB2ST_KERNELS is an internal routine used by the SSYTRD_SB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
real(sp) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = ( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = zero
end do
ctmp = ( a( ofdpos, st ) )
call stdlib${ii}$_slarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_slarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_slarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_slarfx( 'LEFT', ln, lm, v( vpos ),( tau( taupos ) ),a( dpos-nb,&
j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) =( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = zero
end do
ctmp = ( a( dpos-nb, j1 ) )
call stdlib${ii}$_slarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_slarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = zero
end do
call stdlib${ii}$_slarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_slarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_slarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_slarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = zero
end do
call stdlib${ii}$_slarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_slarfx( 'LEFT', lm, ln-1, v( vpos ),( tau( taupos ) ),a( dpos+&
nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_ssb2st_kernels
pure module subroutine stdlib${ii}$_dsb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! DSB2ST_KERNELS is an internal routine used by the DSYTRD_SB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
real(dp) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = ( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = zero
end do
ctmp = ( a( ofdpos, st ) )
call stdlib${ii}$_dlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_dlarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_dlarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_dlarfx( 'LEFT', ln, lm, v( vpos ),( tau( taupos ) ),a( dpos-nb,&
j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) =( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = zero
end do
ctmp = ( a( dpos-nb, j1 ) )
call stdlib${ii}$_dlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_dlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = zero
end do
call stdlib${ii}$_dlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_dlarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_dlarfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_dlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = zero
end do
call stdlib${ii}$_dlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_dlarfx( 'LEFT', lm, ln-1, v( vpos ),( tau( taupos ) ),a( dpos+&
nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_dsb2st_kernels
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! DSB2ST_KERNELS: is an internal routine used by the DSYTRD_SB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
real(${rk}$) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = ( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = zero
end do
ctmp = ( a( ofdpos, st ) )
call stdlib${ii}$_${ri}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ri}$larfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ri}$larfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_${ri}$larfx( 'LEFT', ln, lm, v( vpos ),( tau( taupos ) ),a( dpos-nb,&
j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) =( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = zero
end do
ctmp = ( a( dpos-nb, j1 ) )
call stdlib${ii}$_${ri}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_${ri}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = zero
end do
call stdlib${ii}$_${ri}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ri}$larfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ri}$larfy( uplo, lm, v( vpos ), 1_${ik}$,( tau( taupos ) ),a( dpos, st ), &
lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_${ri}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = one
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = zero
end do
call stdlib${ii}$_${ri}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_${ri}$larfx( 'LEFT', lm, ln-1, v( vpos ),( tau( taupos ) ),a( dpos+&
nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_${ri}$sb2st_kernels
#:endif
#:endfor
module subroutine stdlib${ii}$_chegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info )
!! CHEGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork== -1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n-1 ) .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_cpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_cheev( jobz, uplo, n, a, lda, w, work, lwork, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h*y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chegv
module subroutine stdlib${ii}$_zhegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info )
!! ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n - 1_${ik}$ ) .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_zpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_zheev( jobz, uplo, n, a, lda, w, work, lwork, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhegv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info )
!! ZHEGV: computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian and B is also
!! positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n - 1_${ik}$ ) .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ci}$heev( jobz, uplo, n, a, lda, w, work, lwork, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda &
)
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hegv
#:endif
#:endfor
module subroutine stdlib${ii}$_chegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,&
!! CHEGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = lwmin
lropt = lrwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_cpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_cheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork,iwork, liwork,&
info )
lopt = max( real( lopt,KIND=sp), real( work( 1_${ik}$ ),KIND=sp) )
lropt = max( real( lropt,KIND=sp), real( rwork( 1_${ik}$ ),KIND=sp) )
liopt = max( real( liopt,KIND=sp), real( iwork( 1_${ik}$ ),KIND=sp) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_chegvd
module subroutine stdlib${ii}$_zhegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,&
!! ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = lwmin
lropt = lrwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_zpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_zheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork,iwork, liwork,&
info )
lopt = max( real( lopt,KIND=dp), real( work( 1_${ik}$ ),KIND=dp) )
lropt = max( real( lropt,KIND=dp), real( rwork( 1_${ik}$ ),KIND=dp) )
liopt = max( real( liopt,KIND=dp), real( iwork( 1_${ik}$ ),KIND=dp) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_zhegvd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,&
!! ZHEGVD: computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = lwmin
lropt = lrwmin
liopt = liwmin
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ci}$heevd( jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork,iwork, liwork,&
info )
lopt = max( real( lopt,KIND=${ck}$), real( work( 1_${ik}$ ),KIND=${ck}$) )
lropt = max( real( lropt,KIND=${ck}$), real( rwork( 1_${ik}$ ),KIND=${ck}$) )
liopt = max( real( liopt,KIND=${ck}$), real( iwork( 1_${ik}$ ),KIND=${ck}$) )
if( wantz .and. info==0_${ik}$ ) then
! backtransform eigenvectors to the original problem.
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda )
end if
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_${ci}$hegvd
#:endif
#:endfor
module subroutine stdlib${ii}$_chegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! CHEGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*), b(ldb,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_cpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_cheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, rwork, iwork, ifail,info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h*y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chegvx
module subroutine stdlib${ii}$_zhegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! ZHEGVX computes selected eigenvalues, and optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*), b(ldb,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_zpotrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_zheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, rwork, iwork, ifail,info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhegvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,&
!! ZHEGVX: computes selected eigenvalues, and optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian and B is also positive definite.
!! Eigenvalues and eigenvectors can be selected by specifying either a
!! range of values or a range of indices for the desired eigenvalues.
m, w, z, ldz, work,lwork, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${ck}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz
character :: trans
integer(${ik}$) :: lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldb<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -12_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -13_${ik}$
end if
end if
end if
if (info==0_${ik}$) then
if (ldz<1_${ik}$ .or. (wantz .and. ldz<n)) then
info = -18_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n ) .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEGVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$potrf( uplo, n, b, ldb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info )
call stdlib${ii}$_${ci}$heevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, &
work, lwork, rwork, iwork, ifail,info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz )
end if
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hegvx
#:endif
#:endfor
module subroutine stdlib${ii}$_chpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info )
!! CHPGV computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ap(*), bp(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_cpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_chpev( jobz, uplo, n, ap, w, z, ldz, work, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h*y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_chpgv
module subroutine stdlib${ii}$_zhpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info )
!! ZHPGV computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ap(*), bp(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_zpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_zhpgv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info )
!! ZHPGV: computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
!! Here A and B are assumed to be Hermitian, stored in packed format,
!! and B is also positive definite.
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ap(*), bp(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: trans
integer(${ik}$) :: j, neig
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ci}$hpev( jobz, uplo, n, ap, w, z, ldz, work, rwork, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hpgv
#:endif
#:endfor
module subroutine stdlib${ii}$_chpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,&
!! CHPGVD computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ap(*), bp(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else
if( wantz ) then
lwmin = 2_${ik}$*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_cpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_chpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, rwork,lrwork, iwork, &
liwork, info )
lwmin = max( real( lwmin,KIND=sp), real( work( 1_${ik}$ ),KIND=sp) )
lrwmin = max( real( lrwmin,KIND=sp), real( rwork( 1_${ik}$ ),KIND=sp) )
liwmin = max( real( liwmin,KIND=sp), real( iwork( 1_${ik}$ ),KIND=sp) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_chpgvd
module subroutine stdlib${ii}$_zhpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,&
!! ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ap(*), bp(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else
if( wantz ) then
lwmin = 2_${ik}$*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_zpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_zhpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, rwork,lrwork, iwork, &
liwork, info )
lwmin = max( real( lwmin,KIND=dp), real( work( 1_${ik}$ ),KIND=dp) )
lrwmin = max( real( lrwmin,KIND=dp), real( rwork( 1_${ik}$ ),KIND=dp) )
liwmin = max( real( liwmin,KIND=dp), real( iwork( 1_${ik}$ ),KIND=dp) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zhpgvd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,&
!! ZHPGVD: computes all the eigenvalues and, optionally, the eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite.
!! If eigenvectors are desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
iwork, liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ap(*), bp(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: trans
integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else
if( wantz ) then
lwmin = 2_${ik}$*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -13_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -15_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ci}$hpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, rwork,lrwork, iwork, &
liwork, info )
lwmin = max( real( lwmin,KIND=${ck}$), real( work( 1_${ik}$ ),KIND=${ck}$) )
lrwmin = max( real( lrwmin,KIND=${ck}$), real( rwork( 1_${ik}$ ),KIND=${ck}$) )
liwmin = max( real( liwmin,KIND=${ck}$), real( iwork( 1_${ik}$ ),KIND=${ck}$) )
if( wantz ) then
! backtransform eigenvectors to the original problem.
neig = n
if( info>0_${ik}$ )neig = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, neig
call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, neig
call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$hpgvd
#:endif
#:endfor
module subroutine stdlib${ii}$_chpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! CHPGVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite. Eigenvalues and eigenvectors can be selected by
!! specifying either a range of values or a range of indices for the
!! desired eigenvalues.
z, ldz, work, rwork,iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ap(*), bp(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPGVX', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_cpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_chpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_chpevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, rwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, m
call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h*y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_chpgvx
module subroutine stdlib${ii}$_zhpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! ZHPGVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite. Eigenvalues and eigenvectors can be selected by
!! specifying either a range of values or a range of indices for the
!! desired eigenvalues.
z, ldz, work, rwork,iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ap(*), bp(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGVX', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_zpptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_zhpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_zhpevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, rwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, m
call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_zhpgvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, &
!! ZHPGVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a complex generalized Hermitian-definite eigenproblem, of the form
!! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
!! B are assumed to be Hermitian, stored in packed format, and B is also
!! positive definite. Eigenvalues and eigenvectors can be selected by
!! specifying either a range of values or a range of indices for the
!! desired eigenvalues.
z, ldz, work, rwork,iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, itype, iu, ldz, n
integer(${ik}$), intent(out) :: info, m
real(${ck}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ap(*), bp(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, upper, valeig, wantz
character :: trans
integer(${ik}$) :: j
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then
info = -1_${ik}$
else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -2_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -3_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl ) then
info = -9_${ik}$
end if
else if( indeig ) then
if( il<1_${ik}$ ) then
info = -10_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -11_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -16_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPGVX', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a cholesky factorization of b.
call stdlib${ii}$_${ci}$pptrf( uplo, n, bp, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem and solve.
call stdlib${ii}$_${ci}$hpgst( itype, uplo, n, ap, bp, info )
call stdlib${ii}$_${ci}$hpevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m,w, z, ldz, &
work, rwork, iwork, ifail, info )
if( wantz ) then
! backtransform eigenvectors to the original problem.
if( info>0_${ik}$ )m = info - 1_${ik}$
if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then
! for a*x=(lambda)*b*x and a*b*x=(lambda)*x;
! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y
if( upper ) then
trans = 'N'
else
trans = 'C'
end if
do j = 1, m
call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
else if( itype==3_${ik}$ ) then
! for b*a*x=(lambda)*x;
! backtransform eigenvectors: x = l*y or u**h *y
if( upper ) then
trans = 'C'
else
trans = 'N'
end if
do j = 1, m
call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ )
end do
end if
end if
return
end subroutine stdlib${ii}$_${ci}$hpgvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! CHBGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite.
rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_cpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_chbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork( &
indwrk ), iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_chbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_csteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indwrk ), info )
end if
return
end subroutine stdlib${ii}$_chbgv
pure module subroutine stdlib${ii}$_zhbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! ZHBGV computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite.
rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_zpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_zhbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork( &
indwrk ), iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_zhbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_zsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indwrk ), info )
end if
return
end subroutine stdlib${ii}$_zhbgv
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, &
!! ZHBGV: computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite.
rwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwrk
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGV ', -info )
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ci}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork( &
indwrk ), iinfo )
! reduce to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, call stdlib${ii}$_${ci}$steqr.
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indwrk ), info )
end if
return
end subroutine stdlib${ii}$_${ci}$hbgv
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! CHBGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, rwork, lrwork, iwork,liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llrwk, llwk2, lrwmin, &
lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$+n
lrwmin = 1_${ik}$+n
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n**2_${ik}$
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_cpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 2_${ik}$
llrwk = lrwork - indwrk + 2_${ik}$
call stdlib${ii}$_chbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork, &
iinfo )
! reduce hermitian band matrix to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_chbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_cstedc.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_cstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( &
indwrk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_cgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), &
n )
call stdlib${ii}$_clacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_chbgvd
pure module subroutine stdlib${ii}$_zhbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, rwork, lrwork, iwork,liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llrwk, llwk2, lrwmin, &
lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$+n
lrwmin = 1_${ik}$+n
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n**2_${ik}$
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_zpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 2_${ik}$
llrwk = lrwork - indwrk + 2_${ik}$
call stdlib${ii}$_zhbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork, &
iinfo )
! reduce hermitian band matrix to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_zhbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_zstedc.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_zstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( &
indwrk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_zgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), &
n )
call stdlib${ii}$_zlacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zhbgvd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, &
!! ZHBGVD: computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. If eigenvectors are
!! desired, it uses a divide and conquer algorithm.
!! The divide and conquer algorithm makes very mild assumptions about
!! floating point arithmetic. It will work on machines with a guard
!! digit in add/subtract, or on those binary machines without guard
!! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!! Cray-2. It could conceivably fail on hexadecimal or decimal machines
!! without guard digits, but we know of none.
lwork, rwork, lrwork, iwork,liwork, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper, wantz
character :: vect
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llrwk, llwk2, lrwmin, &
lwmin
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$+n
lrwmin = 1_${ik}$+n
liwmin = 1_${ik}$
else if( wantz ) then
lwmin = 2_${ik}$*n**2_${ik}$
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n
lrwmin = n
liwmin = 1_${ik}$
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ka<0_${ik}$ ) then
info = -4_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -5_${ik}$
else if( ldab<ka+1 ) then
info = -7_${ik}$
else if( ldbb<kb+1 ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -14_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -16_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -18_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ci}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 2_${ik}$
llrwk = lrwork - indwrk + 2_${ik}$
call stdlib${ii}$_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork, &
iinfo )
! reduce hermitian band matrix to tridiagonal form.
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, call stdlib${ii}$_${ci}$stedc.
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_${ci}$stedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( &
indwrk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), &
n )
call stdlib${ii}$_${ci}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$hbgvd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! CHBGVX computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(sp), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwk, indrwk, indwrk, &
itmp1, j, jj, nsplit
real(sp) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_cpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_chbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, rwork, &
iinfo )
! solve the standard eigenvalue problem.
! reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_chbtrd( vect, uplo, n, ka, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_csteqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_sstebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_scopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indrwk + 2_${ik}$*n
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_clacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired,
! call stdlib${ii}$_cstein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwk = indisp + n
call stdlib${ii}$_sstebz( range, order, n, vl, vu, il, iu, abstol,rwork( indd ), rwork( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ), &
info )
if( wantz ) then
call stdlib${ii}$_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_cstein.
do j = 1, m
call stdlib${ii}$_ccopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_cgemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_chbgvx
pure module subroutine stdlib${ii}$_zhbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(dp), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwk, indrwk, indwrk, &
itmp1, j, jj, nsplit
real(dp) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_zpbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_zhbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, rwork, &
iinfo )
! solve the standard eigenvalue problem.
! reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_zhbtrd( vect, uplo, n, ka, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zsteqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_dstebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_dcopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indrwk + 2_${ik}$*n
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_zlacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired,
! call stdlib${ii}$_zstein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwk = indisp + n
call stdlib${ii}$_dstebz( range, order, n, vl, vu, il, iu, abstol,rwork( indd ), rwork( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ), &
info )
if( wantz ) then
call stdlib${ii}$_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_zstein.
do j = 1, m
call stdlib${ii}$_zcopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_zgemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_zhbgvx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, &
!! ZHBGVX: computes all the eigenvalues, and optionally, the eigenvectors
!! of a complex generalized Hermitian-definite banded eigenproblem, of
!! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
!! and banded, and B is also positive definite. Eigenvalues and
!! eigenvectors can be selected by specifying either all eigenvalues,
!! a range of values or a range of indices for the desired eigenvalues.
vu, il, iu, abstol, m, w, z,ldz, work, rwork, iwork, ifail, info )
! -- lapack driver routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range, uplo
integer(${ik}$), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n
integer(${ik}$), intent(out) :: info, m
real(${ck}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*)
complex(${ck}$), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, upper, valeig, wantz
character :: order, vect
integer(${ik}$) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwk, indrwk, indwrk, &
itmp1, j, jj, nsplit
real(${ck}$) :: tmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
upper = stdlib_lsame( uplo, 'U' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( alleig .or. valeig .or. indeig ) ) then
info = -2_${ik}$
else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( ka<0_${ik}$ ) then
info = -5_${ik}$
else if( kb<0_${ik}$ .or. kb>ka ) then
info = -6_${ik}$
else if( ldab<ka+1 ) then
info = -8_${ik}$
else if( ldbb<kb+1 ) then
info = -10_${ik}$
else if( ldq<1_${ik}$ .or. ( wantz .and. ldq<n ) ) then
info = -12_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -15_${ik}$
else if ( iu<min( n, il ) .or. iu>n ) then
info = -16_${ik}$
end if
end if
end if
if( info==0_${ik}$) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -21_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBGVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! form a split cholesky factorization of b.
call stdlib${ii}$_${ci}$pbstf( uplo, n, kb, bb, ldbb, info )
if( info/=0_${ik}$ ) then
info = n + info
return
end if
! transform problem to standard eigenvalue problem.
call stdlib${ii}$_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, rwork, &
iinfo )
! solve the standard eigenvalue problem.
! reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
if( wantz ) then
vect = 'U'
else
vect = 'N'
end if
call stdlib${ii}$_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, &
work( indwrk ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$steqr. if this fails for some
! eigenvalue, then try stdlib${ii}$_${c2ri(ci)}$stebz.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ )
indee = indrwk + 2_${ik}$*n
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_${ci}$lacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info )
if( info==0_${ik}$ ) then
do i = 1, n
ifail( i ) = 0_${ik}$
end do
end if
end if
if( info==0_${ik}$ ) then
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired,
! call stdlib${ii}$_${ci}$stein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
indibl = 1_${ik}$
indisp = indibl + n
indiwk = indisp + n
call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vl, vu, il, iu, abstol,rwork( indd ), rwork( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ), &
info )
if( wantz ) then
call stdlib${ii}$_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ci}$stein.
do j = 1, m
call stdlib${ii}$_${ci}$copy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
call stdlib${ii}$_${ci}$gemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
30 continue
! if eigenvalues are not in order, then sort them, along with
! eigenvectors.
if( wantz ) then
do j = 1, m - 1
i = 0_${ik}$
tmp1 = w( j )
do jj = j + 1, m
if( w( jj )<tmp1 ) then
i = jj
tmp1 = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
itmp1 = iwork( indibl+i-1 )
w( i ) = w( j )
iwork( indibl+i-1 ) = iwork( indibl+j-1 )
w( j ) = tmp1
iwork( indibl+j-1 ) = itmp1
call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
if( info/=0_${ik}$ ) then
itmp1 = ifail( i )
ifail( i ) = ifail( j )
ifail( j ) = itmp1
end if
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$hbgvx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! CHETRD reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(sp), intent(out) :: d(*), e(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_clatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_cher2k( uplo, 'NO TRANSPOSE', i-1, nb, -cone,a( 1_${ik}$, i ), lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = real( a( j, j ),KIND=sp)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_chetd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_clatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+nb:n,i+nb:n), using
! an update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_cher2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -cone,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = real( a( j, j ),KIND=sp)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_chetd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_chetrd
pure module subroutine stdlib${ii}$_zhetrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! ZHETRD reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(dp), intent(out) :: d(*), e(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_zlatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_zher2k( uplo, 'NO TRANSPOSE', i-1, nb, -cone,a( 1_${ik}$, i ), lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = real( a( j, j ),KIND=dp)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_zhetd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_zlatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+nb:n,i+nb:n), using
! an update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_zher2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -cone,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = real( a( j, j ),KIND=dp)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_zhetd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zhetrd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, d, e, tau, work, lwork, info )
!! ZHETRD: reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: d(*), e(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<1_${ik}$ .and. .not.lquery ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
! determine the block size.
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = n*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
nx = n
iws = 1_${ik}$
if( nb>1_${ik}$ .and. nb<n ) then
! determine when to cross over from blocked to unblocked code
! (last block is always handled by unblocked code).
nx = max( nb, stdlib${ii}$_ilaenv( 3_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
if( nx<n ) then
! determine if workspace is large enough for blocked code.
ldwork = n
iws = ldwork*nb
if( lwork<iws ) then
! not enough workspace to use optimal nb: determine the
! minimum value of nb, and reduce nb or force use of
! unblocked code by setting nx = n.
nb = max( lwork / ldwork, 1_${ik}$ )
nbmin = stdlib${ii}$_ilaenv( 2_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<nbmin )nx = n
end if
else
nx = n
end if
else
nb = 1_${ik}$
end if
if( upper ) then
! reduce the upper triangle of a.
! columns 1:kk are handled by the unblocked method.
kk = n - ( ( n-nx+nb-1 ) / nb )*nb
do i = n - nb + 1, kk + 1, -nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_${ci}$latrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork )
! update the unreduced submatrix a(1:i-1,1:i-1), using an
! update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_${ci}$her2k( uplo, 'NO TRANSPOSE', i-1, nb, -cone,a( 1_${ik}$, i ), lda, work, &
ldwork, one, a, lda )
! copy superdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j-1, j ) = e( j-1 )
d( j ) = real( a( j, j ),KIND=${ck}$)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_${ci}$hetd2( uplo, kk, a, lda, d, e, tau, iinfo )
else
! reduce the lower triangle of a
do i = 1, n - nx, nb
! reduce columns i:i+nb-1 to tridiagonal form and form the
! matrix w which is needed to update the unreduced part of
! the matrix
call stdlib${ii}$_${ci}$latrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, &
ldwork )
! update the unreduced submatrix a(i+nb:n,i+nb:n), using
! an update of the form: a := a - v*w**h - w*v**h
call stdlib${ii}$_${ci}$her2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -cone,a( i+nb, i ), lda, &
work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda )
! copy subdiagonal elements back into a, and diagonal
! elements into d
do j = i, i + nb - 1
a( j+1, j ) = e( j )
d( j ) = real( a( j, j ),KIND=${ck}$)
end do
end do
! use unblocked code to reduce the last or only block
call stdlib${ii}$_${ci}$hetd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$hetrd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chetd2( uplo, n, a, lda, d, e, tau, info )
!! CHETD2 reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(sp), intent(out) :: d(*), e(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(sp) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
a( n, n ) = real( a( n, n ),KIND=sp)
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(1:i-1,i+1)
alpha = a( i, i+1 )
call stdlib${ii}$_clarfg( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=sp)
if( taui/=czero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = cone
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_chemv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, czero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_cdotc( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_caxpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_cher2( uplo, i, -cone, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
else
a( i, i ) = real( a( i, i ),KIND=sp)
end if
a( i, i+1 ) = e( i )
d( i+1 ) = real( a( i+1, i+1 ),KIND=sp)
tau( i ) = taui
end do
d( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
else
! reduce the lower triangle of a
a( 1_${ik}$, 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(i+2:n,i)
alpha = a( i+1, i )
call stdlib${ii}$_clarfg( n-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=sp)
if( taui/=czero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = cone
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_chemv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, czero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_cdotc( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_caxpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_cher2( uplo, n-i, -cone, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 )&
, lda )
else
a( i+1, i+1 ) = real( a( i+1, i+1 ),KIND=sp)
end if
a( i+1, i ) = e( i )
d( i ) = real( a( i, i ),KIND=sp)
tau( i ) = taui
end do
d( n ) = real( a( n, n ),KIND=sp)
end if
return
end subroutine stdlib${ii}$_chetd2
pure module subroutine stdlib${ii}$_zhetd2( uplo, n, a, lda, d, e, tau, info )
!! ZHETD2 reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(dp), intent(out) :: d(*), e(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(dp) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U')
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
a( n, n ) = real( a( n, n ),KIND=dp)
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(1:i-1,i+1)
alpha = a( i, i+1 )
call stdlib${ii}$_zlarfg( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=dp)
if( taui/=czero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = cone
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_zhemv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, czero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_zdotc( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_zaxpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_zher2( uplo, i, -cone, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
else
a( i, i ) = real( a( i, i ),KIND=dp)
end if
a( i, i+1 ) = e( i )
d( i+1 ) = real( a( i+1, i+1 ),KIND=dp)
tau( i ) = taui
end do
d( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
else
! reduce the lower triangle of a
a( 1_${ik}$, 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(i+2:n,i)
alpha = a( i+1, i )
call stdlib${ii}$_zlarfg( n-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=dp)
if( taui/=czero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = cone
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_zhemv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, czero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_zdotc( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_zaxpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_zher2( uplo, n-i, -cone, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 )&
, lda )
else
a( i+1, i+1 ) = real( a( i+1, i+1 ),KIND=dp)
end if
a( i+1, i ) = e( i )
d( i ) = real( a( i, i ),KIND=dp)
tau( i ) = taui
end do
d( n ) = real( a( n, n ),KIND=dp)
end if
return
end subroutine stdlib${ii}$_zhetd2
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hetd2( uplo, n, a, lda, d, e, tau, info )
!! ZHETD2: reduces a complex Hermitian matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, n
! Array Arguments
real(${ck}$), intent(out) :: d(*), e(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: tau(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i
complex(${ck}$) :: alpha, taui
! Intrinsic Functions
! Executable Statements
! test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U')
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETD2', -info )
return
end if
! quick return if possible
if( n<=0 )return
if( upper ) then
! reduce the upper triangle of a
a( n, n ) = real( a( n, n ),KIND=${ck}$)
do i = n - 1, 1, -1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(1:i-1,i+1)
alpha = a( i, i+1 )
call stdlib${ii}$_${ci}$larfg( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=${ck}$)
if( taui/=czero ) then
! apply h(i) from both sides to a(1:i,1:i)
a( i, i+1 ) = cone
! compute x := tau * a * v storing x in tau(1:i)
call stdlib${ii}$_${ci}$hemv( uplo, i, taui, a, lda, a( 1_${ik}$, i+1 ), 1_${ik}$, czero,tau, 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_${ci}$dotc( i, tau, 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( i, alpha, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_${ci}$her2( uplo, i, -cone, a( 1_${ik}$, i+1 ), 1_${ik}$, tau, 1_${ik}$, a,lda )
else
a( i, i ) = real( a( i, i ),KIND=${ck}$)
end if
a( i, i+1 ) = e( i )
d( i+1 ) = real( a( i+1, i+1 ),KIND=${ck}$)
tau( i ) = taui
end do
d( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
else
! reduce the lower triangle of a
a( 1_${ik}$, 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
do i = 1, n - 1
! generate elementary reflector h(i) = i - tau * v * v**h
! to annihilate a(i+2:n,i)
alpha = a( i+1, i )
call stdlib${ii}$_${ci}$larfg( n-i, alpha, a( min( i+2, n ), i ), 1_${ik}$, taui )
e( i ) = real( alpha,KIND=${ck}$)
if( taui/=czero ) then
! apply h(i) from both sides to a(i+1:n,i+1:n)
a( i+1, i ) = cone
! compute x := tau * a * v storing y in tau(i:n-1)
call stdlib${ii}$_${ci}$hemv( uplo, n-i, taui, a( i+1, i+1 ), lda,a( i+1, i ), 1_${ik}$, czero, &
tau( i ), 1_${ik}$ )
! compute w := x - 1/2 * tau * (x**h * v) * v
alpha = -chalf*taui*stdlib${ii}$_${ci}$dotc( n-i, tau( i ), 1_${ik}$, a( i+1, i ),1_${ik}$ )
call stdlib${ii}$_${ci}$axpy( n-i, alpha, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$ )
! apply the transformation as a rank-2 update:
! a := a - v * w**h - w * v**h
call stdlib${ii}$_${ci}$her2( uplo, n-i, -cone, a( i+1, i ), 1_${ik}$, tau( i ), 1_${ik}$,a( i+1, i+1 )&
, lda )
else
a( i+1, i+1 ) = real( a( i+1, i+1 ),KIND=${ck}$)
end if
a( i+1, i ) = e( i )
d( i ) = real( a( i, i ),KIND=${ck}$)
tau( i ) = taui
end do
d( n ) = real( a( n, n ),KIND=${ck}$)
end if
return
end subroutine stdlib${ii}$_${ci}$hetd2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cungtr( uplo, n, a, lda, tau, work, lwork, info )
!! CUNGTR generates a complex unitary matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! CHETRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if ( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_chetrd with uplo = 'u'
! shift the vectors which define the elementary reflectors cone
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = czero
end do
do i = 1, n - 1
a( i, n ) = czero
end do
a( n, n ) = cone
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_cungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_chetrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = czero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = cone
do i = 2, n
a( i, 1_${ik}$ ) = czero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_cungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cungtr
pure module subroutine stdlib${ii}$_zungtr( uplo, n, a, lda, tau, work, lwork, info )
!! ZUNGTR generates a complex unitary matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! ZHETRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_zhetrd with uplo = 'u'
! shift the vectors which define the elementary reflectors cone
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = czero
end do
do i = 1, n - 1
a( i, n ) = czero
end do
a( n, n ) = cone
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_zungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_zhetrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = czero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = cone
do i = 2, n
a( i, 1_${ik}$ ) = czero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_zungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zungtr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$ungtr( uplo, n, a, lda, tau, work, lwork, info )
!! ZUNGTR: generates a complex unitary matrix Q which is defined as the
!! product of n-1 elementary reflectors of order N, as returned by
!! ZHETRD:
!! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
!! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, lwork, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, iinfo, j, lwkopt, nb
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ )
upper = stdlib_lsame( uplo, 'U' )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( lwork<max( 1_${ik}$, n-1 ) .and. .not.lquery ) then
info = -7_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQL', ' ', n-1, n-1, n-1, -1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n-1, n-1, n-1, -1_${ik}$ )
end if
lwkopt = max( 1_${ik}$, n-1 )*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNGTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_${ci}$hetrd with uplo = 'u'
! shift the vectors which define the elementary reflectors cone
! column to the left, and set the last row and column of q to
! those of the unit matrix
do j = 1, n - 1
do i = 1, j - 1
a( i, j ) = a( i, j+1 )
end do
a( n, j ) = czero
end do
do i = 1, n - 1
a( i, n ) = czero
end do
a( n, n ) = cone
! generate q(1:n-1,1:n-1)
call stdlib${ii}$_${ci}$ungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_${ci}$hetrd with uplo = 'l'.
! shift the vectors which define the elementary reflectors cone
! column to the right, and set the first row and column of q to
! those of the unit matrix
do j = n, 2, -1
a( 1_${ik}$, j ) = czero
do i = j + 1, n
a( i, j ) = a( i, j-1 )
end do
end do
a( 1_${ik}$, 1_${ik}$ ) = cone
do i = 2, n
a( i, 1_${ik}$ ) = czero
end do
if( n>1_${ik}$ ) then
! generate q(2:n,2:n)
call stdlib${ii}$_${ci}$ungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo )
end if
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$ungtr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! CUNMTR overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by CHETRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
complex(sp), intent(inout) :: a(lda,*), c(ldc,*)
complex(sp), intent(in) :: tau(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CUNMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_chetrd with uplo = 'u'
call stdlib${ii}$_cunmql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_chetrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_cunmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cunmtr
pure module subroutine stdlib${ii}$_zunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! ZUNMTR overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by ZHETRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
complex(dp), intent(inout) :: a(lda,*), c(ldc,*)
complex(dp), intent(in) :: tau(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_zhetrd with uplo = 'u'
call stdlib${ii}$_zunmql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_zhetrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_zunmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zunmtr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$unmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, &
!! ZUNMTR: overwrites the general complex M-by-N matrix C with
!! SIDE = 'L' SIDE = 'R'
!! TRANS = 'N': Q * C C * Q
!! TRANS = 'C': Q**H * C C * Q**H
!! where Q is a complex unitary matrix of order nq, with nq = m if
!! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
!! nq-1 elementary reflectors, as returned by ZHETRD:
!! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
!! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: side, trans, uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*)
complex(${ck}$), intent(in) :: tau(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: left, lquery, upper
integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw
! Intrinsic Functions
! Executable Statements
! test the input arguments
info = 0_${ik}$
left = stdlib_lsame( side, 'L' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
! nq is the order of q and nw is the minimum dimension of work
if( left ) then
nq = m
nw = max( 1_${ik}$, n )
else
nq = n
nw = max( 1_${ik}$, m )
end if
if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then
info = -1_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -2_${ik}$
else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )&
then
info = -3_${ik}$
else if( m<0_${ik}$ ) then
info = -4_${ik}$
else if( n<0_${ik}$ ) then
info = -5_${ik}$
else if( lda<max( 1_${ik}$, nq ) ) then
info = -7_${ik}$
else if( ldc<max( 1_${ik}$, m ) ) then
info = -10_${ik}$
else if( lwork<nw .and. .not.lquery ) then
info = -12_${ik}$
end if
if( info==0_${ik}$ ) then
if( upper ) then
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQL', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
else
if( left ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ )
else
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ )
end if
end if
lwkopt = nw*nb
work( 1_${ik}$ ) = lwkopt
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZUNMTR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( m==0_${ik}$ .or. n==0_${ik}$ .or. nq==1_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( left ) then
mi = m - 1_${ik}$
ni = n
else
mi = m
ni = n - 1_${ik}$
end if
if( upper ) then
! q was determined by a call to stdlib${ii}$_${ci}$hetrd with uplo = 'u'
call stdlib${ii}$_${ci}$unmql( side, trans, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda, tau, c,ldc, work, &
lwork, iinfo )
else
! q was determined by a call to stdlib${ii}$_${ci}$hetrd with uplo = 'l'
if( left ) then
i1 = 2_${ik}$
i2 = 1_${ik}$
else
i1 = 1_${ik}$
i2 = 2_${ik}$
end if
call stdlib${ii}$_${ci}$unmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), ldc,&
work, lwork, iinfo )
end if
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$unmtr
#:endif
#:endfor
module subroutine stdlib${ii}$_chetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! CHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian
!! band-diagonal form AB by a unitary similarity transformation:
!! Q**H * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'CHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRD_HE2HB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_ccopy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_ccopy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to czero once such a
! way every time t is generated the upper/lower portion will be always czero
call stdlib${ii}$_claset( "A", ldt, kd, czero, czero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_cgelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_ccopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_claset( 'LOWER', pk, pk, czero, cone,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,cone, work( tpos ), &
ldt,a( i, i+kd ), lda,czero, work( s2pos ), lds2 )
call stdlib${ii}$_chemm( 'RIGHT', uplo, pk, pn,cone, a( i+kd, i+kd ), lda,work( &
s2pos ), lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,cone, work( wpos ), &
ldw,work( s2pos ), lds2,czero, work( s1pos ), lds1 )
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-chalf, work( &
s1pos ), lds1,a( i, i+kd ), lda,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_cher2k( uplo, 'CONJUGATE', pn, pk,-cone, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_ccopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_cgeqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_ccopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_claset( 'UPPER', pk, pk, czero, cone,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_clarft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,cone, a( i+kd, i )&
, lda,work( tpos ), ldt,czero, work( s2pos ), lds2 )
call stdlib${ii}$_chemm( 'LEFT', uplo, pn, pk,cone, a( i+kd, i+kd ), lda,work( s2pos )&
, lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,cone, work( s2pos ), &
lds2,work( wpos ), ldw,czero, work( s1pos ), lds1 )
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-chalf, a( i+kd, &
i ), lda,work( s1pos ), lds1,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_cher2k( uplo, 'NO TRANSPOSE', pn, pk,-cone, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_ccopy( llk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_ccopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_chetrd_he2hb
module subroutine stdlib${ii}$_zhetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! ZHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian
!! band-diagonal form AB by a unitary similarity transformation:
!! Q**H * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD_HE2HB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_zcopy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_zcopy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to czero once such a
! way every time t is generated the upper/lower portion will be always czero
call stdlib${ii}$_zlaset( "A", ldt, kd, czero, czero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_zgelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_zcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_zlaset( 'LOWER', pk, pk, czero, cone,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,cone, work( tpos ), &
ldt,a( i, i+kd ), lda,czero, work( s2pos ), lds2 )
call stdlib${ii}$_zhemm( 'RIGHT', uplo, pk, pn,cone, a( i+kd, i+kd ), lda,work( &
s2pos ), lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,cone, work( wpos ), &
ldw,work( s2pos ), lds2,czero, work( s1pos ), lds1 )
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-chalf, work( &
s1pos ), lds1,a( i, i+kd ), lda,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_zher2k( uplo, 'CONJUGATE', pn, pk,-cone, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_zcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_zgeqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_zcopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_zlaset( 'UPPER', pk, pk, czero, cone,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_zlarft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,cone, a( i+kd, i )&
, lda,work( tpos ), ldt,czero, work( s2pos ), lds2 )
call stdlib${ii}$_zhemm( 'LEFT', uplo, pn, pk,cone, a( i+kd, i+kd ), lda,work( s2pos )&
, lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,cone, work( s2pos ), &
lds2,work( wpos ), ldw,czero, work( s1pos ), lds1 )
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-chalf, a( i+kd, &
i ), lda,work( s1pos ), lds1,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_zher2k( uplo, 'NO TRANSPOSE', pn, pk,-cone, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_zcopy( nlk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_zcopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_zhetrd_he2hb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! ZHETRD_HE2HB: reduces a complex Hermitian matrix A to complex Hermitian
!! band-diagonal form AB by a unitary similarity transformation:
!! Q**H * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD_HE2HB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_${ci}$copy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_${ci}$copy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to czero once such a
! way every time t is generated the upper/lower portion will be always czero
call stdlib${ii}$_${ci}$laset( "A", ldt, kd, czero, czero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_${ci}$gelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_${ci}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_${ci}$laset( 'LOWER', pk, pk, czero, cone,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,cone, work( tpos ), &
ldt,a( i, i+kd ), lda,czero, work( s2pos ), lds2 )
call stdlib${ii}$_${ci}$hemm( 'RIGHT', uplo, pk, pn,cone, a( i+kd, i+kd ), lda,work( &
s2pos ), lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,cone, work( wpos ), &
ldw,work( s2pos ), lds2,czero, work( s1pos ), lds1 )
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-chalf, work( &
s1pos ), lds1,a( i, i+kd ), lda,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_${ci}$her2k( uplo, 'CONJUGATE', pn, pk,-cone, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_${ci}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_${ci}$geqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_${ci}$copy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_${ci}$laset( 'UPPER', pk, pk, czero, cone,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_${ci}$larft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,cone, a( i+kd, i )&
, lda,work( tpos ), ldt,czero, work( s2pos ), lds2 )
call stdlib${ii}$_${ci}$hemm( 'LEFT', uplo, pn, pk,cone, a( i+kd, i+kd ), lda,work( s2pos )&
, lds2,czero, work( wpos ), ldw )
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,cone, work( s2pos ), &
lds2,work( wpos ), ldw,czero, work( s1pos ), lds1 )
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-chalf, a( i+kd, &
i ), lda,work( s1pos ), lds1,cone, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_${ci}$her2k( uplo, 'NO TRANSPOSE', pn, pk,-cone, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_${ci}$copy( llk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_${ci}$copy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_${ci}$hetrd_he2hb
#:endif
#:endfor
module subroutine stdlib${ii}$_chetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! CHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(out) :: d(*), e(*)
complex(sp), intent(inout) :: ab(ldab,*)
complex(sp), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sicev, sizetau, ldv, lhmin, lwmin
real(sp) :: abstmp
complex(sp) :: tmp
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'CHETRD_HB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'CHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'CHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHETRD_HB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sicev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! complex because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=sp)
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=sp)
end do
! make off-diagonal elements real and copy them to e
if( upper ) then
do i = 1, n - 1
tmp = ab( abofdpos, i+1 )
abstmp = abs( tmp )
ab( abofdpos, i+1 ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+2 ) = ab( abofdpos, i+2 )*tmp
! if( wantz ) then
! call stdlib${ii}$_cscal( n, conjg( tmp ), q( 1, i+1 ), 1 )
! end if
end do
else
do i = 1, n - 1
tmp = ab( abofdpos, i )
abstmp = abs( tmp )
ab( abofdpos, i ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+1 ) = ab( abofdpos, i+1 )*tmp
! if( wantq ) then
! call stdlib${ii}$_cscal( n, tmp, q( 1, i+1 ), 1 )
! end if
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the hermitian band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=sp)/real(kd,KIND=sp) )
stepercol = ceiling( real(shift,KIND=sp)/real(grsiz,KIND=sp) )
thgrnb = ceiling( real(n-1,KIND=sp)/real(thgrsiz,KIND=sp) )
call stdlib${ii}$_clacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_claset( "A", kd, n, czero, czero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_chb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_chb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be czero.
do i = 1, n
d( i ) = real( work( dpos+(i-1)*lda ),KIND=sp)
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be czero.
if( upper ) then
do i = 1, n-1
e( i ) = real( work( ofdpos+i*lda ),KIND=sp)
end do
else
do i = 1, n-1
e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=sp)
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_chetrd_hb2st
module subroutine stdlib${ii}$_zhetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! ZHETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(out) :: d(*), e(*)
complex(dp), intent(inout) :: ab(ldab,*)
complex(dp), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sizev, sizetau, ldv, lhmin, lwmin
real(dp) :: abstmp
complex(dp) :: tmp
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD_HB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sizev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! complex because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=dp)
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=dp)
end do
! make off-diagonal elements real and copy them to e
if( upper ) then
do i = 1, n - 1
tmp = ab( abofdpos, i+1 )
abstmp = abs( tmp )
ab( abofdpos, i+1 ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+2 ) = ab( abofdpos, i+2 )*tmp
! if( wantz ) then
! call stdlib${ii}$_zscal( n, conjg( tmp ), q( 1, i+1 ), 1 )
! end if
end do
else
do i = 1, n - 1
tmp = ab( abofdpos, i )
abstmp = abs( tmp )
ab( abofdpos, i ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+1 ) = ab( abofdpos, i+1 )*tmp
! if( wantq ) then
! call stdlib${ii}$_zscal( n, tmp, q( 1, i+1 ), 1 )
! end if
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the hermitian band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=dp)/real(kd,KIND=dp) )
stepercol = ceiling( real(shift,KIND=dp)/real(grsiz,KIND=dp) )
thgrnb = ceiling( real(n-1,KIND=dp)/real(thgrsiz,KIND=dp) )
call stdlib${ii}$_zlacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_zlaset( "A", kd, n, czero, czero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_zhb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_zhb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be czero.
do i = 1, n
d( i ) = real( work( dpos+(i-1)*lda ),KIND=dp)
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be czero.
if( upper ) then
do i = 1, n-1
e( i ) = real( work( ofdpos+i*lda ),KIND=dp)
end do
else
do i = 1, n-1
e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=dp)
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_zhetrd_hb2st
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! ZHETRD_HB2ST: reduces a complex Hermitian band matrix A to real symmetric
!! tridiagonal form T by a unitary similarity transformation:
!! Q**H * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${ck}$), intent(out) :: d(*), e(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
complex(${ck}$), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sizev, sizetau, ldv, lhmin, lwmin
real(${ck}$) :: abstmp
complex(${ck}$) :: tmp
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHETRD_HB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sizev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! complex because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=${ck}$)
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = real( ab( abdpos, i ),KIND=${ck}$)
end do
! make off-diagonal elements real and copy them to e
if( upper ) then
do i = 1, n - 1
tmp = ab( abofdpos, i+1 )
abstmp = abs( tmp )
ab( abofdpos, i+1 ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+2 ) = ab( abofdpos, i+2 )*tmp
! if( wantz ) then
! call stdlib${ii}$_${ci}$scal( n, conjg( tmp ), q( 1, i+1 ), 1 )
! end if
end do
else
do i = 1, n - 1
tmp = ab( abofdpos, i )
abstmp = abs( tmp )
ab( abofdpos, i ) = abstmp
e( i ) = abstmp
if( abstmp/=zero ) then
tmp = tmp / abstmp
else
tmp = cone
end if
if( i<n-1 )ab( abofdpos, i+1 ) = ab( abofdpos, i+1 )*tmp
! if( wantq ) then
! call stdlib${ii}$_${ci}$scal( n, tmp, q( 1, i+1 ), 1 )
! end if
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the hermitian band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=${ck}$)/real(kd,KIND=${ck}$) )
stepercol = ceiling( real(shift,KIND=${ck}$)/real(grsiz,KIND=${ck}$) )
thgrnb = ceiling( real(n-1,KIND=${ck}$)/real(thgrsiz,KIND=${ck}$) )
call stdlib${ii}$_${ci}$lacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_${ci}$laset( "A", kd, n, czero, czero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be czero.
do i = 1, n
d( i ) = real( work( dpos+(i-1)*lda ),KIND=${ck}$)
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be czero.
if( upper ) then
do i = 1, n-1
e( i ) = real( work( ofdpos+i*lda ),KIND=${ck}$)
end do
else
do i = 1, n-1
e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=${ck}$)
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_${ci}$hetrd_hb2st
#:endif
#:endfor
pure module subroutine stdlib${ii}$_chb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! CHB2ST_KERNELS is an internal routine used by the CHETRD_HB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
complex(sp) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = conjg( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = czero
end do
ctmp = conjg( a( ofdpos, st ) )
call stdlib${ii}$_clarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_clarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( &
dpos-nb, j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) =conjg( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = czero
end do
ctmp = conjg( a( dpos-nb, j1 ) )
call stdlib${ii}$_clarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_clarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = czero
end do
call stdlib${ii}$_clarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_clarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = czero
end do
call stdlib${ii}$_clarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_clarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( &
dpos+nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_chb2st_kernels
pure module subroutine stdlib${ii}$_zhb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! ZHB2ST_KERNELS is an internal routine used by the ZHETRD_HB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
complex(dp) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = conjg( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = czero
end do
ctmp = conjg( a( ofdpos, st ) )
call stdlib${ii}$_zlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_zlarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( &
dpos-nb, j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) =conjg( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = czero
end do
ctmp = conjg( a( dpos-nb, j1 ) )
call stdlib${ii}$_zlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_zlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = czero
end do
call stdlib${ii}$_zlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_zlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = czero
end do
call stdlib${ii}$_zlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_zlarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( &
dpos+nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_zhb2st_kernels
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, &
!! ZHB2ST_KERNELS: is an internal routine used by the ZHETRD_HB2ST
!! subroutine.
v, tau, ldvt, work)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
logical(lk), intent(in) :: wantz
integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt
! Array Arguments
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: v(*), tau(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: upper
integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter
complex(${ck}$) :: ctmp
! Intrinsic Functions
! Executable Statements
ajeter = ib + ldvt
upper = stdlib_lsame( uplo, 'U' )
if( upper ) then
dpos = 2_${ik}$ * nb + 1_${ik}$
ofdpos = 2_${ik}$ * nb
else
dpos = 1_${ik}$
ofdpos = 2_${ik}$
endif
! upper case
if( upper ) then
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = conjg( a( ofdpos-i, st+i ) )
a( ofdpos-i, st+i ) = czero
end do
ctmp = conjg( a( ofdpos, st ) )
call stdlib${ii}$_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) )
a( ofdpos, st ) = ctmp
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_${ci}$larfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( &
dpos-nb, j1 ), lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) =conjg( a( dpos-nb-i, j1+i ) )
a( dpos-nb-i, j1+i ) = czero
end do
ctmp = conjg( a( dpos-nb, j1 ) )
call stdlib${ii}$_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) )
a( dpos-nb, j1 ) = ctmp
call stdlib${ii}$_${ci}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+&
1_${ik}$, j1 ), lda-1, work)
endif
endif
! lower case
else
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + st
taupos = mod( sweep-1, 2_${ik}$ ) * n + st
endif
if( ttype==1_${ik}$ ) then
lm = ed - st + 1_${ik}$
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( ofdpos+i, st-1 )
a( ofdpos+i, st-1 ) = czero
end do
call stdlib${ii}$_${ci}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==3_${ik}$ ) then
lm = ed - st + 1_${ik}$
call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )&
, lda-1, work)
endif
if( ttype==2_${ik}$ ) then
j1 = ed+1
j2 = min( ed+nb, n )
ln = ed-st+1
lm = j2-j1+1
if( lm>0_${ik}$) then
call stdlib${ii}$_${ci}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, &
st ),lda-1, work)
if( wantz ) then
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
else
vpos = mod( sweep-1, 2_${ik}$ ) * n + j1
taupos = mod( sweep-1, 2_${ik}$ ) * n + j1
endif
v( vpos ) = cone
do i = 1, lm-1
v( vpos+i ) = a( dpos+nb+i, st )
a( dpos+nb+i, st ) = czero
end do
call stdlib${ii}$_${ci}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) )
call stdlib${ii}$_${ci}$larfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( &
dpos+nb-1, st+1 ), lda-1, work)
endif
endif
endif
return
end subroutine stdlib${ii}$_${ci}$hb2st_kernels
#:endif
#:endfor
module subroutine stdlib${ii}$_ssytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric
!! tridiagonal form T by a orthogonal similarity transformation:
!! Q**T * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(sp), intent(out) :: d(*), e(*)
real(sp), intent(inout) :: ab(ldab,*)
real(sp), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sisev, sizetau, ldv, lhmin, lwmin
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'SSYTRD_SB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'SSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'SSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRD_SB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sisev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! real because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
if( upper ) then
do i = 1, n-1
e( i ) = ( ab( abofdpos, i+1 ) )
end do
else
do i = 1, n-1
e( i ) = ( ab( abofdpos, i ) )
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the symmetric band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=sp)/real(kd,KIND=sp) )
stepercol = ceiling( real(shift,KIND=sp)/real(grsiz,KIND=sp) )
thgrnb = ceiling( real(n-1,KIND=sp)/real(thgrsiz,KIND=sp) )
call stdlib${ii}$_slacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_slaset( "A", kd, n, zero, zero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_ssb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_ssb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be zero.
do i = 1, n
d( i ) = ( work( dpos+(i-1)*lda ) )
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be zero.
if( upper ) then
do i = 1, n-1
e( i ) = ( work( ofdpos+i*lda ) )
end do
else
do i = 1, n-1
e( i ) = ( work( ofdpos+(i-1)*lda ) )
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_ssytrd_sb2st
module subroutine stdlib${ii}$_dsytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! DSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric
!! tridiagonal form T by a orthogonal similarity transformation:
!! Q**T * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(dp), intent(out) :: d(*), e(*)
real(dp), intent(inout) :: ab(ldab,*)
real(dp), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sidev, sizetau, ldv, lhmin, lwmin
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD_SB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sidev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! real because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
if( upper ) then
do i = 1, n-1
e( i ) = ( ab( abofdpos, i+1 ) )
end do
else
do i = 1, n-1
e( i ) = ( ab( abofdpos, i ) )
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the symmetric band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=dp)/real(kd,KIND=dp) )
stepercol = ceiling( real(shift,KIND=dp)/real(grsiz,KIND=dp) )
thgrnb = ceiling( real(n-1,KIND=dp)/real(thgrsiz,KIND=dp) )
call stdlib${ii}$_dlacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_dlaset( "A", kd, n, zero, zero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_dsb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_dsb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be zero.
do i = 1, n
d( i ) = ( work( dpos+(i-1)*lda ) )
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be zero.
if( upper ) then
do i = 1, n-1
e( i ) = ( work( ofdpos+i*lda ) )
end do
else
do i = 1, n-1
e( i ) = ( work( ofdpos+(i-1)*lda ) )
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_dsytrd_sb2st
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, &
!! DSYTRD_SB2ST: reduces a real symmetric band matrix A to real symmetric
!! tridiagonal form T by a orthogonal similarity transformation:
!! Q**T * A * Q = T.
work, lwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: stage1, uplo, vect
integer(${ik}$), intent(in) :: n, kd, ldab, lhous, lwork
integer(${ik}$), intent(out) :: info
! Array Arguments
real(${rk}$), intent(out) :: d(*), e(*)
real(${rk}$), intent(inout) :: ab(ldab,*)
real(${rk}$), intent(out) :: hous(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, wantq, upper, afters1
integer(${ik}$) :: i, m, k, ib, sweepid, myid, shift, stt, st, ed, stind, edind, &
blklastind, colpt, thed, stepercol, grsiz, thgrsiz, thgrnb, thgrid, nbtiles, ttype, &
tid, nthreads, debug, abdpos, abofdpos, dpos, ofdpos, awpos, inda, indw, apos, sizea, &
lda, indv, indtau, sidev, sizetau, ldv, lhmin, lwmin
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required.
! test the input parameters
debug = 0_${ik}$
info = 0_${ik}$
afters1 = stdlib_lsame( stage1, 'Y' )
wantq = stdlib_lsame( vect, 'V' )
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ ) .or. ( lhous==-1_${ik}$ )
! determine the block size, the workspace size and the hous size.
ib = stdlib${ii}$_ilaenv2stage( 2_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, -1_${ik}$, -1_${ik}$ )
lhmin = stdlib${ii}$_ilaenv2stage( 3_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'DSYTRD_SB2ST', vect, n, kd, ib, -1_${ik}$ )
if( .not.afters1 .and. .not.stdlib_lsame( stage1, 'N' ) ) then
info = -1_${ik}$
else if( .not.stdlib_lsame( vect, 'N' ) ) then
info = -2_${ik}$
else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else if( kd<0_${ik}$ ) then
info = -5_${ik}$
else if( ldab<(kd+1) ) then
info = -7_${ik}$
else if( lhous<lhmin .and. .not.lquery ) then
info = -11_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -13_${ik}$
end if
if( info==0_${ik}$ ) then
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD_SB2ST', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine pointer position
ldv = kd + ib
sizetau = 2_${ik}$ * n
sidev = 2_${ik}$ * n
indtau = 1_${ik}$
indv = indtau + sizetau
lda = 2_${ik}$ * kd + 1_${ik}$
sizea = lda * n
inda = 1_${ik}$
indw = inda + sizea
nthreads = 1_${ik}$
tid = 0_${ik}$
if( upper ) then
apos = inda + kd
awpos = inda
dpos = apos + kd
ofdpos = dpos - 1_${ik}$
abdpos = kd + 1_${ik}$
abofdpos = kd
else
apos = inda
awpos = inda + kd + 1_${ik}$
dpos = apos
ofdpos = dpos + 1_${ik}$
abdpos = 1_${ik}$
abofdpos = 2_${ik}$
endif
! case kd=0:
! the matrix is diagonal. we just copy it (convert to "real" for
! real because d is double and the imaginary part should be 0)
! and store it in d. a sequential code here is better or
! in a parallel environment it might need two cores for d and e
if( kd==0_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
do i = 1, n-1
e( i ) = zero
end do
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! case kd=1:
! the matrix is already tridiagonal. we have to make diagonal
! and offdiagonal elements real, and store them in d and e.
! for that, for real precision just copy the diag and offdiag
! to d and e while for the complex case the bulge chasing is
! performed to convert the hermetian tridiagonal to symmetric
! tridiagonal. a simpler conversion formula might be used, but then
! updating the q matrix will be required and based if q is generated
! or not this might complicate the story.
if( kd==1_${ik}$ ) then
do i = 1, n
d( i ) = ( ab( abdpos, i ) )
end do
if( upper ) then
do i = 1, n-1
e( i ) = ( ab( abofdpos, i+1 ) )
end do
else
do i = 1, n-1
e( i ) = ( ab( abofdpos, i ) )
end do
endif
hous( 1_${ik}$ ) = 1_${ik}$
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! main code start here.
! reduce the symmetric band of a to a tridiagonal matrix.
thgrsiz = n
grsiz = 1_${ik}$
shift = 3_${ik}$
nbtiles = ceiling( real(n,KIND=${rk}$)/real(kd,KIND=${rk}$) )
stepercol = ceiling( real(shift,KIND=${rk}$)/real(grsiz,KIND=${rk}$) )
thgrnb = ceiling( real(n-1,KIND=${rk}$)/real(thgrsiz,KIND=${rk}$) )
call stdlib${ii}$_${ri}$lacpy( "A", kd+1, n, ab, ldab, work( apos ), lda )
call stdlib${ii}$_${ri}$laset( "A", kd, n, zero, zero, work( awpos ), lda )
! openmp parallelisation start here
!$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) &
!$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) &
!$OMP& PRIVATE( MYID, TTYPE, COLPT, STIND, EDIND ) &
!$OMP& SHARED ( UPLO, WANTQ, INDV, INDTAU, HOUS, WORK) &
!$OMP& SHARED ( N, KD, IB, NBTILES, LDA, LDV, INDA ) &
!$OMP& SHARED ( STEPERCOL, THGRNB, THGRSIZ, GRSIZ, SHIFT )
!$OMP MASTER
! main bulge chasing loop
loop_100: do thgrid = 1, thgrnb
stt = (thgrid-1)*thgrsiz+1
thed = min( (stt + thgrsiz -1_${ik}$), (n-1))
loop_110: do i = stt, n-1
ed = min( i, thed )
if( stt>ed ) exit
loop_120: do m = 1, stepercol
st = stt
loop_130: do sweepid = st, ed
loop_140: do k = 1, grsiz
myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k
if ( myid==1_${ik}$ ) then
ttype = 1_${ik}$
else
ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$
endif
if( ttype==2_${ik}$ ) then
colpt = (myid/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
blklastind = colpt
else
colpt = ((myid+1)/2_${ik}$)*kd + sweepid
stind = colpt-kd+1
edind = min(colpt,n)
if( ( stind>=edind-1 ).and.( edind==n ) ) then
blklastind = n
else
blklastind = 0_${ik}$
endif
endif
! call the kernel
!$ if( ttype/=1 ) then
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(in:WORK(MYID-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
!$ call stdlib${ii}$_${ri}$sb2st_kernels( uplo, wantq, ttype,stind, edind, &
!$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
!$ indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ else
!$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) &
!$OMP& DEPEND(out:WORK(MYID))
!$ tid = omp_get_thread_num()
call stdlib${ii}$_${ri}$sb2st_kernels( uplo, wantq, ttype,stind, edind, &
sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( &
indtau ), ldv,work( indw + tid*kd ) )
!$OMP END TASK
!$ endif
if ( blklastind>=(n-1) ) then
stt = stt + 1_${ik}$
exit
endif
end do loop_140
end do loop_130
end do loop_120
end do loop_110
end do loop_100
!$OMP END MASTER
!$OMP END PARALLEL
! copy the diagonal from a to d. note that d is real thus only
! the real part is needed, the imaginary part should be zero.
do i = 1, n
d( i ) = ( work( dpos+(i-1)*lda ) )
end do
! copy the off diagonal from a to e. note that e is real thus only
! the real part is needed, the imaginary part should be zero.
if( upper ) then
do i = 1, n-1
e( i ) = ( work( ofdpos+i*lda ) )
end do
else
do i = 1, n-1
e( i ) = ( work( ofdpos+(i-1)*lda ) )
end do
endif
hous( 1_${ik}$ ) = lhmin
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_${ri}$sytrd_sb2st
#:endif
#:endfor
module subroutine stdlib${ii}$_ssytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! SSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric
!! band-diagonal form AB by a orthogonal similarity transformation:
!! Q**T * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'SSYTRD_SY2SB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYTRD_SY2SB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_scopy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_scopy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to zero once such a
! way every time t is generated the upper/lower portion will be always zero
call stdlib${ii}$_slaset( "A", ldt, kd, zero, zero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_sgelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_scopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_slaset( 'LOWER', pk, pk, zero, one,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_slarft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_sgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,one, work( tpos ), &
ldt,a( i, i+kd ), lda,zero, work( s2pos ), lds2 )
call stdlib${ii}$_ssymm( 'RIGHT', uplo, pk, pn,one, a( i+kd, i+kd ), lda,work( s2pos &
), lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,one, work( wpos ), &
ldw,work( s2pos ), lds2,zero, work( s1pos ), lds1 )
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-half, work( &
s1pos ), lds1,a( i, i+kd ), lda,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_ssyr2k( uplo, 'CONJUGATE', pn, pk,-one, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_scopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_sgeqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_scopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_slaset( 'UPPER', pk, pk, zero, one,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_slarft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,one, a( i+kd, i ),&
lda,work( tpos ), ldt,zero, work( s2pos ), lds2 )
call stdlib${ii}$_ssymm( 'LEFT', uplo, pn, pk,one, a( i+kd, i+kd ), lda,work( s2pos ),&
lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_sgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,one, work( s2pos ), &
lds2,work( wpos ), ldw,zero, work( s1pos ), lds1 )
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-half, a( i+kd, i &
), lda,work( s1pos ), lds1,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_ssyr2k( uplo, 'NO TRANSPOSE', pn, pk,-one, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_scopy( llk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_scopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_ssytrd_sy2sb
module subroutine stdlib${ii}$_dsytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric
!! band-diagonal form AB by a orthogonal similarity transformation:
!! Q**T * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'DSYTRD_SY2SB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD_SY2SB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_dcopy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_dcopy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to zero once such a
! way every time t is generated the upper/lower portion will be always zero
call stdlib${ii}$_dlaset( "A", ldt, kd, zero, zero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_dgelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_dcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_dlaset( 'LOWER', pk, pk, zero, one,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_dlarft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_dgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,one, work( tpos ), &
ldt,a( i, i+kd ), lda,zero, work( s2pos ), lds2 )
call stdlib${ii}$_dsymm( 'RIGHT', uplo, pk, pn,one, a( i+kd, i+kd ), lda,work( s2pos &
), lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,one, work( wpos ), &
ldw,work( s2pos ), lds2,zero, work( s1pos ), lds1 )
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-half, work( &
s1pos ), lds1,a( i, i+kd ), lda,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_dsyr2k( uplo, 'CONJUGATE', pn, pk,-one, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_dcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_dgeqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_dcopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_dlaset( 'UPPER', pk, pk, zero, one,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_dlarft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,one, a( i+kd, i ),&
lda,work( tpos ), ldt,zero, work( s2pos ), lds2 )
call stdlib${ii}$_dsymm( 'LEFT', uplo, pn, pk,one, a( i+kd, i+kd ), lda,work( s2pos ),&
lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_dgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,one, work( s2pos ), &
lds2,work( wpos ), ldw,zero, work( s1pos ), lds1 )
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-half, a( i+kd, i &
), lda,work( s1pos ), lds1,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_dsyr2k( uplo, 'NO TRANSPOSE', pn, pk,-one, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_dcopy( llk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_dcopy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_dsytrd_sy2sb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info )
!! DSYTRD_SY2SB: reduces a real symmetric matrix A to real symmetric
!! band-diagonal form AB by a orthogonal similarity transformation:
!! Q**T * A * Q = AB.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: ab(ldab,*), tau(*), work(*)
! =====================================================================
! Parameters
! Local Scalars
logical(lk) :: lquery, upper
integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,&
tpos, wpos, s2pos, s1pos
! Intrinsic Functions
! Executable Statements
! determine the minimal workspace size required
! and test the input parameters
info = 0_${ik}$
upper = stdlib_lsame( uplo, 'U' )
lquery = ( lwork==-1_${ik}$ )
lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'DSYTRD_SY2SB', '', n, kd, -1_${ik}$, -1_${ik}$ )
if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( kd<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( ldab<max( 1_${ik}$, kd+1 ) ) then
info = -7_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYTRD_SY2SB', -info )
return
else if( lquery ) then
work( 1_${ik}$ ) = lwmin
return
end if
! quick return if possible
! copy the upper/lower portion of a into ab
if( n<=kd+1 ) then
if( upper ) then
do i = 1, n
llk = min( kd+1, i )
call stdlib${ii}$_${ri}$copy( llk, a( i-llk+1, i ), 1_${ik}$,ab( kd+1-llk+1, i ), 1_${ik}$ )
end do
else
do i = 1, n
llk = min( kd+1, n-i+1 )
call stdlib${ii}$_${ri}$copy( llk, a( i, i ), 1_${ik}$, ab( 1_${ik}$, i ), 1_${ik}$ )
end do
endif
work( 1_${ik}$ ) = 1_${ik}$
return
end if
! determine the pointer position for the workspace
ldt = kd
lds1 = kd
lt = ldt*kd
lw = n*kd
ls1 = lds1*kd
ls2 = lwmin - lt - lw - ls1
! ls2 = n*max(kd,factoptnb)
tpos = 1_${ik}$
wpos = tpos + lt
s1pos = wpos + lw
s2pos = s1pos + ls1
if( upper ) then
ldw = kd
lds2 = kd
else
ldw = n
lds2 = n
endif
! set the workspace of the triangular matrix t to zero once such a
! way every time t is generated the upper/lower portion will be always zero
call stdlib${ii}$_${ri}$laset( "A", ldt, kd, zero, zero, work( tpos ), ldt )
if( upper ) then
do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the lq factorization of the current block
call stdlib${ii}$_${ri}$gelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_${ri}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
call stdlib${ii}$_${ri}$laset( 'LOWER', pk, pk, zero, one,a( i, i+kd ), lda )
! form the matrix t
call stdlib${ii}$_${ri}$larft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_${ri}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,one, work( tpos ), &
ldt,a( i, i+kd ), lda,zero, work( s2pos ), lds2 )
call stdlib${ii}$_${ri}$symm( 'RIGHT', uplo, pk, pn,one, a( i+kd, i+kd ), lda,work( s2pos &
), lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,one, work( wpos ), &
ldw,work( s2pos ), lds2,zero, work( s1pos ), lds1 )
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-half, work( &
s1pos ), lds1,a( i, i+kd ), lda,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v'*w - w'*v
call stdlib${ii}$_${ri}$syr2k( uplo, 'CONJUGATE', pn, pk,-one, a( i, i+kd ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
end do
! copy the upper band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_${ri}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 )
end do
else
! reduce the lower triangle of a to lower band matrix
loop_40: do i = 1, n - kd, kd
pn = n-i-kd+1
pk = min( n-i-kd+1, kd )
! compute the qr factorization of the current block
call stdlib${ii}$_${ri}$geqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, &
iinfo )
! copy the upper portion of a into ab
do j = i, i+pk-1
llk = min( kd, n-j ) + 1_${ik}$
call stdlib${ii}$_${ri}$copy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$laset( 'UPPER', pk, pk, zero, one,a( i+kd, i ), lda )
! form the matrix t
call stdlib${ii}$_${ri}$larft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),&
work( tpos ), ldt )
! compute w:
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,one, a( i+kd, i ),&
lda,work( tpos ), ldt,zero, work( s2pos ), lds2 )
call stdlib${ii}$_${ri}$symm( 'LEFT', uplo, pn, pk,one, a( i+kd, i+kd ), lda,work( s2pos ),&
lds2,zero, work( wpos ), ldw )
call stdlib${ii}$_${ri}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,one, work( s2pos ), &
lds2,work( wpos ), ldw,zero, work( s1pos ), lds1 )
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-half, a( i+kd, i &
), lda,work( s1pos ), lds1,one, work( wpos ), ldw )
! update the unreduced submatrix a(i+kd:n,i+kd:n), using
! an update of the form: a := a - v*w' - w*v'
call stdlib${ii}$_${ri}$syr2k( uplo, 'NO TRANSPOSE', pn, pk,-one, a( i+kd, i ), lda,work( &
wpos ), ldw,one, a( i+kd, i+kd ), lda )
! ==================================================================
! restore a for comparison and checking to be removed
! do 45 j = i, i+pk-1
! llk = min( kd, n-j ) + 1
! call stdlib${ii}$_${ri}$copy( llk, ab( 1, j ), 1, a( j, j ), 1 )
45 continue
! ==================================================================
end do loop_40
! copy the lower band to ab which is the band storage matrix
do j = n-kd+1, n
llk = min(kd, n-j) + 1_${ik}$
call stdlib${ii}$_${ri}$copy( llk, a( j, j ), 1_${ik}$, ab( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
work( 1_${ik}$ ) = lwmin
return
end subroutine stdlib${ii}$_${ri}$sytrd_sy2sb
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_sym
