#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_std_driver
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
module subroutine stdlib${ii}$_ssyev( jobz, uplo, n, a, lda, w, work, lwork, info )
!! SSYEV computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb+2 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 3_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
work( 1_${ik}$ ) = 2_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_slascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_sorgtr to generate the orthogonal matrix, then call stdlib${ii}$_ssteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( inde ), info )
else
call stdlib${ii}$_sorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssyev
module subroutine stdlib${ii}$_dsyev( jobz, uplo, n, a, lda, w, work, lwork, info )
!! DSYEV computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb+2 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 3_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
work( 1_${ik}$ ) = 2_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_dlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_dorgtr to generate the orthogonal matrix, then call stdlib${ii}$_dsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( inde ), info )
else
call stdlib${ii}$_dorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsyev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$syev( jobz, uplo, n, a, lda, w, work, lwork, info )
!! DSYEV: computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
lwkopt = max( 1_${ik}$, ( nb+2 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 3_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
work( 1_${ik}$ ) = 2_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_${ri}$sytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ri}$sytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ri}$orgtr to generate the orthogonal matrix, then call stdlib${ii}$_${ri}$steqr.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( inde ), info )
else
call stdlib${ii}$_${ri}$orgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
call stdlib${ii}$_${ri}$steqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$syev
#:endif
#:endfor
module subroutine stdlib${ii}$_ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info )
!! SSYEVD computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A. 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.
!! Because of large use of BLAS of level 3, SSYEVD needs N**2 more
!! workspace than SSYEVX.
! -- 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) :: lda, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, &
llwrk2, lopt, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
lopt = lwmin
liopt = liwmin
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 = max( lwmin, 2_${ik}$*n +stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_slascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_sstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_sormtr to multiply it by the
! householder transformations stored in a.
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}$_sormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_slacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_ssyevd
module subroutine stdlib${ii}$_dsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info )
!! DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A. 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.
!! Because of large use of BLAS of level 3, DSYEVD needs N**2 more
!! workspace than DSYEVX.
! -- 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) :: lda, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, &
llwrk2, lopt, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
lopt = lwmin
liopt = liwmin
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 = max( lwmin, 2_${ik}$*n +stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_dlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_dstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_dormtr to multiply it by the
! householder transformations stored in a.
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}$_dormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_dlacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_dsyevd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$syevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info )
!! DSYEVD: computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A. 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.
!! Because of large use of BLAS of level 3, DSYEVD needs N**2 more
!! workspace than DSYEVX.
! -- 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) :: lda, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: w(*), work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, &
llwrk2, lopt, lwmin
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
lopt = lwmin
liopt = liwmin
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 = max( lwmin, 2_${ik}$*n +stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -10_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansy( 'M', uplo, n, a, lda, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_${ri}$sytrd to reduce symmetric matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_${ri}$sytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ri}$stedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_${ri}$ormtr to multiply it by the
! householder transformations stored in a.
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}$ormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$scal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lopt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_${ri}$syevd
#:endif
#:endfor
module subroutine stdlib${ii}$_ssyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! SSYEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! SSYEVR first reduces the matrix A to tridiagonal form T with a call
!! to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute
!! the eigenspectrum using Relatively Robust Representations. SSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see SSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of SSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(sp), intent(inout) :: a(lda,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indd, inddd, inde, indee, indibl, indifl, &
indisp, indiwo, indtau, indwk, indwkn, iscale, j, jj, liwmin, llwork, llwrkn, lwkopt, &
lwmin, nb, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'SSYEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( liwork==-1_${ik}$ ) )
lwmin = max( 1_${ik}$, 26_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 26_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_sscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_sscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_ssterf or stdlib${ii}$_sstemr fail.
! work(indtau:indtau+n-1) stores the scalar factors of the
! elementary reflectors used in stdlib${ii}$_ssytrd.
indtau = 1_${ik}$
! work(indd:indd+n-1) stores the tridiagonal's diagonal entries.
indd = indtau + n
! work(inde:inde+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_ssytrd.
inde = indd + n
! work(inddd:inddd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_sstemr (the stdlib${ii}$_ssterf path copies the diagonal to w).
inddd = inde + n
! work(indee:indee+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_ssterf and stdlib${ii}$_sstemr.
indee = inddd + n
! indwk is the starting offset of the left-over workspace, and
! llwork is the remaining workspace size.
indwk = indee + n
llwork = lwork - indwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_sstebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_sstebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_sstein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form.
call stdlib${ii}$_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_ssterf or stdlib${ii}$_sstemr and stdlib${ii}$_sormtr.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then
if( .not.wantz ) then
call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, work( indee ), info )
else
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, work( inddd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_sstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,&
w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_sstemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
end if
end if
if( info==0_${ik}$ ) then
! everything worked. skip stdlib${ii}$_sstebz/stdlib${ii}$_sstein. iwork(:) are
! undefined.
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein.
! also call stdlib${ii}$_sstebz and stdlib${ii}$_sstein if stdlib${ii}$_sstemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,work( indwk ), iwork( indiwo ), iwork( indifl ),info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_sstein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
! jump here if stdlib${ii}$_sstemr/stdlib${ii}$_sstein succeeded.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! if eigenvalues are not in order, then sort them, along with
! eigenvectors. note: we do not sort the ifail portion of iwork.
! it may not be initialized (if stdlib${ii}$_sstemr/stdlib${ii}$_sstein succeeded), and we do
! not return this detailed information to the user.
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
w( i ) = w( j )
w( j ) = tmp1
call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_ssyevr
module subroutine stdlib${ii}$_dsyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSYEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! DSYEVR first reduces the matrix A to tridiagonal form T with a call
!! to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
!! the eigenspectrum using Relatively Robust Representations. DSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see DSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! DSYEVR calls DSTEBZ and DSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of DSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(dp), intent(inout) :: a(lda,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indd, inddd, inde, indee, indibl, indifl, &
indisp, indiwo, indtau, indwk, indwkn, iscale, j, jj, liwmin, llwork, llwrkn, lwkopt, &
lwmin, nb, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'DSYEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( liwork==-1_${ik}$ ) )
lwmin = max( 1_${ik}$, 26_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 7_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_dsterf or stdlib${ii}$_dstemr fail.
! work(indtau:indtau+n-1) stores the scalar factors of the
! elementary reflectors used in stdlib${ii}$_dsytrd.
indtau = 1_${ik}$
! work(indd:indd+n-1) stores the tridiagonal's diagonal entries.
indd = indtau + n
! work(inde:inde+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_dsytrd.
inde = indd + n
! work(inddd:inddd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_dstemr (the stdlib${ii}$_dsterf path copies the diagonal to w).
inddd = inde + n
! work(indee:indee+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_dsterf and stdlib${ii}$_dstemr.
indee = inddd + n
! indwk is the starting offset of the left-over workspace, and
! llwork is the remaining workspace size.
indwk = indee + n
llwork = lwork - indwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_dstebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_dstebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_dstein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form.
call stdlib${ii}$_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_dsterf or stdlib${ii}$_dstemr and stdlib${ii}$_dormtr.
if( ( alleig .or. ( indeig .and. il==1_${ik}$ .and. iu==n ) ) .and.ieeeok==1_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, work( indee ), info )
else
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, work( inddd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_dstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,&
w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_dstemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
end if
end if
if( info==0_${ik}$ ) then
! everything worked. skip stdlib${ii}$_dstebz/stdlib${ii}$_dstein. iwork(:) are
! undefined.
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_dstein.
! also call stdlib${ii}$_dstebz and stdlib${ii}$_dstein if stdlib${ii}$_dstemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,work( indwk ), iwork( indiwo ), iwork( indifl ),info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_dstein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
! jump here if stdlib${ii}$_dstemr/stdlib${ii}$_dstein succeeded.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! if eigenvalues are not in order, then sort them, along with
! eigenvectors. note: we do not sort the ifail portion of iwork.
! it may not be initialized (if stdlib${ii}$_dstemr/stdlib${ii}$_dstein succeeded), and we do
! not return this detailed information to the user.
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
w( i ) = w( j )
w( j ) = tmp1
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dsyevr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$syevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSYEVR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! DSYEVR first reduces the matrix A to tridiagonal form T with a call
!! to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
!! the eigenspectrum using Relatively Robust Representations. DSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see DSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! DSYEVR calls DSTEBZ and DSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of DSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${rk}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(${rk}$), intent(inout) :: a(lda,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indd, inddd, inde, indee, indibl, indifl, &
indisp, indiwo, indtau, indwk, indwkn, iscale, j, jj, liwmin, llwork, llwrkn, lwkopt, &
lwmin, nb, nsplit
real(${rk}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'DSYEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( liwork==-1_${ik}$ ) )
lwmin = max( 1_${ik}$, 26_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -20_${ik}$
end if
end if
if( info==0_${ik}$ ) then
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 7_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_${ri}$lansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_${ri}$scal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$stemr fail.
! work(indtau:indtau+n-1) stores the scalar factors of the
! elementary reflectors used in stdlib${ii}$_${ri}$sytrd.
indtau = 1_${ik}$
! work(indd:indd+n-1) stores the tridiagonal's diagonal entries.
indd = indtau + n
! work(inde:inde+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_${ri}$sytrd.
inde = indd + n
! work(inddd:inddd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_${ri}$stemr (the stdlib${ii}$_${ri}$sterf path copies the diagonal to w).
inddd = inde + n
! work(indee:indee+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_${ri}$sterf and stdlib${ii}$_${ri}$stemr.
indee = inddd + n
! indwk is the starting offset of the left-over workspace, and
! llwork is the remaining workspace size.
indwk = indee + n
llwork = lwork - indwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_${ri}$stebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_${ri}$stebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_${ri}$stein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_${ri}$sytrd to reduce symmetric matrix to tridiagonal form.
call stdlib${ii}$_${ri}$sytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$stemr and stdlib${ii}$_${ri}$ormtr.
if( ( alleig .or. ( indeig .and. il==1_${ik}$ .and. iu==n ) ) .and.ieeeok==1_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_${ri}$copy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_${ri}$sterf( n, w, work( indee ), info )
else
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n, work( indd ), 1_${ik}$, work( inddd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_${ri}$stemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,&
w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ri}$stemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
end if
end if
if( info==0_${ik}$ ) then
! everything worked. skip stdlib${ii}$_${ri}$stebz/stdlib${ii}$_${ri}$stein. iwork(:) are
! undefined.
m = n
go to 30
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${ri}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ri}$stein.
! also call stdlib${ii}$_${ri}$stebz and stdlib${ii}$_${ri}$stein if stdlib${ii}$_${ri}$stemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde &
), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),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( indwk ), iwork( indiwo ), iwork( indifl ),info )
! apply orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ri}$stein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
! jump here if stdlib${ii}$_${ri}$stemr/stdlib${ii}$_${ri}$stein succeeded.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! if eigenvalues are not in order, then sort them, along with
! eigenvectors. note: we do not sort the ifail portion of iwork.
! it may not be initialized (if stdlib${ii}$_${ri}$stemr/stdlib${ii}$_${ri}$stein succeeded), and we do
! not return this detailed information to the user.
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
w( i ) = w( j )
w( j ) = tmp1
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$syevr
#:endif
#:endfor
module subroutine stdlib${ii}$_ssyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! SSYEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
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, iu, lda, 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,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, &
nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 8_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSYEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_sscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_sscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwrk ), llwork, iinfo )
! if all eigenvalues are desired and abstol is less than or equal to
! zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_sorgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, work( indee ), info )
else
call stdlib${ii}$_slacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_sorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_sstein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_ssyevx
module subroutine stdlib${ii}$_dsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSYEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
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, iu, lda, 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,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, &
nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 8_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwrk ), llwork, iinfo )
! if all eigenvalues are desired and abstol is less than or equal to
! zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_dorgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, work( indee ), info )
else
call stdlib${ii}$_dlacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_dorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, 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}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_dstein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_dsyevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$syevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSYEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A. Eigenvalues and eigenvectors can be
!! selected by specifying either a range of values or a range of indices
!! for the desired eigenvalues.
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, iu, lda, 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,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, &
nsplit
real(${rk}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 8_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSYTRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( lwkmin, ( nb + 3_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSYEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
else
if( vl<a( 1_${ik}$, 1_${ik}$ ) .and. vu>=a( 1_${ik}$, 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_${ri}$lansy( 'M', uplo, n, a, lda, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_${ri}$scal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_${ri}$scal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ri}$sytrd to reduce symmetric matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ri}$sytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( &
indwrk ), llwork, iinfo )
! if all eigenvalues are desired and abstol is less than or equal to
! zero, then call stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$orgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_${ri}$sterf( n, w, work( indee ), info )
else
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_${ri}$orgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${ri}$stebz and, if eigenvectors are desired, 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}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ri}$stein.
indwkn = inde
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ri}$syevx
#:endif
#:endfor
module subroutine stdlib${ii}$_sspev( jobz, uplo, n, ap, w, z, ldz, work, info )
!! SSPEV computes all the eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: ap(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_sopgtr to generate the orthogonal matrix, then call stdlib${ii}$_ssteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_sspev
module subroutine stdlib${ii}$_dspev( jobz, uplo, n, ap, w, z, ldz, work, info )
!! DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: ap(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_dopgtr to generate the orthogonal matrix, then call stdlib${ii}$_dsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dspev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spev( jobz, uplo, n, ap, w, z, ldz, work, info )
!! DSPEV: computes all the eigenvalues and, optionally, eigenvectors of a
!! real symmetric matrix A in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_${ri}$sptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_${ri}$sptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ri}$opgtr to generate the orthogonal matrix, then call stdlib${ii}$_${ri}$steqr.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_${ri}$opgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_${ri}$steqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$spev
#:endif
#:endfor
module subroutine stdlib${ii}$_sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info )
!! SSPEVD computes all the eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. 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.
! -- 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) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: ap(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwrk, iscale, liwmin, llwork, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 + n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
iwork( 1_${ik}$ ) = liwmin
work( 1_${ik}$ ) = lwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -9_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_sstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_sopmtr to multiply it by the
! householder transformations represented in ap.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work( inde ), info )
else
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_sstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, &
liwork, info )
call stdlib${ii}$_sopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sspevd
module subroutine stdlib${ii}$_dspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info )
!! DSPEVD computes all the eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. 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.
! -- 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) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: ap(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwrk, iscale, liwmin, llwork, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 + n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
iwork( 1_${ik}$ ) = liwmin
work( 1_${ik}$ ) = lwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -9_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_dstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_dopmtr to multiply it by the
! householder transformations represented in ap.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work( inde ), info )
else
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_dstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, &
liwork, info )
call stdlib${ii}$_dopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dspevd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info )
!! DSPEVD: computes all the eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. 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.
! -- 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) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: ap(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, inde, indtau, indwrk, iscale, liwmin, llwork, lwmin
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 + n**2_${ik}$
else
liwmin = 1_${ik}$
lwmin = 2_${ik}$*n
end if
end if
iwork( 1_${ik}$ ) = liwmin
work( 1_${ik}$ ) = lwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -9_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -11_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ap( 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansp( 'M', uplo, n, ap, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_${ri}$sptrd to reduce symmetric packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = inde + n
call stdlib${ii}$_${ri}$sptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo )
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ri}$stedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_${ri}$opmtr to multiply it by the
! householder transformations represented in ap.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work( inde ), info )
else
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ri}$stedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, &
liwork, info )
call stdlib${ii}$_${ri}$opmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$scal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$spevd
#:endif
#:endfor
module subroutine stdlib${ii}$_sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! SSPEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. Eigenvalues/vectors
!! can be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, 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(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwrk, iscale, itmp1, j, jj, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
else
if( vl<ap( 1_${ik}$ ) .and. vu>=ap( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if ( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
endif
anrm = stdlib${ii}$_slansp( 'M', uplo, n, ap, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
call stdlib${ii}$_ssptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_sopgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, work( indee ), info )
else
call stdlib${ii}$_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_sstein.
call stdlib${ii}$_sopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_sspevx
module subroutine stdlib${ii}$_dspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSPEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. Eigenvalues/vectors
!! can be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, 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(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwrk, iscale, itmp1, j, jj, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
else
if( vl<ap( 1_${ik}$ ) .and. vu>=ap( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_dlansp( 'M', uplo, n, ap, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
call stdlib${ii}$_dsptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_dopgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, work( indee ), info )
else
call stdlib${ii}$_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, 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}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_dstein.
call stdlib${ii}$_dopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_dspevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$spevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSPEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric matrix A in packed storage. Eigenvalues/vectors
!! can be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, 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(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, &
indwrk, iscale, itmp1, j, jj, nsplit
real(${rk}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
else
if( vl<ap( 1_${ik}$ ) .and. vu>=ap( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = ap( 1_${ik}$ )
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_${ri}$lansp( 'M', uplo, n, ap, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ri}$sptrd to reduce symmetric packed matrix to tridiagonal form.
indtau = 1_${ik}$
inde = indtau + n
indd = inde + n
indwrk = indd + n
call stdlib${ii}$_${ri}$sptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$opgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_${ri}$sterf( n, w, work( indee ), info )
else
call stdlib${ii}$_${ri}$opgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${ri}$stebz and, if eigenvectors are desired, 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}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ri}$stein.
call stdlib${ii}$_${ri}$opmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$spevx
#:endif
#:endfor
module subroutine stdlib${ii}$_ssbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info )
!! SSBEV computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(sp), intent(inout) :: ab(ldab,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indwrk, iscale
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'SSBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
else
w( 1_${ik}$ ) = ab( kd+1, 1_${ik}$ )
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_ssbev
module subroutine stdlib${ii}$_dsbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info )
!! DSBEV computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(dp), intent(inout) :: ab(ldab,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indwrk, iscale
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'DSBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
else
w( 1_${ik}$ ) = ab( kd+1, 1_${ik}$ )
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dsbev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info )
!! DSBEV: computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: ab(ldab,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indwrk, iscale
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'DSBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
else
w( 1_${ik}$ ) = ab( kd+1, 1_${ik}$ )
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ri}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ri}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_${ri}$sbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
call stdlib${ii}$_${ri}$sbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$sbev
#:endif
#:endfor
module subroutine stdlib${ii}$_ssbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, liwork, &
!! SSBEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A. 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) :: kd, ldab, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: ab(ldab,*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, iscale, liwmin, llwrk2, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
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( 'SSBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_slansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_ssbevd
module subroutine stdlib${ii}$_dsbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, liwork, &
!! DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A. 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) :: kd, ldab, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: ab(ldab,*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, iscale, liwmin, llwrk2, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
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( 'DSBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_dlansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dsbevd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, liwork, &
!! DSBEVD: computes all the eigenvalues and, optionally, eigenvectors of
!! a real symmetric band matrix A. 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) :: kd, ldab, ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: ab(ldab,*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, inde, indwk2, indwrk, iscale, liwmin, llwrk2, lwmin
real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${ik}$
end if
if( info==0_${ik}$ ) then
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( 'DSBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = ab( 1_${ik}$, 1_${ik}$ )
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ri}$lansb( 'M', uplo, n, kd, ab, ldab, work )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ri}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ri}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_${ri}$sbtrd to reduce symmetric band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = indwrk + n*n
llwrk2 = lwork - indwk2 + 1_${ik}$
call stdlib${ii}$_${ri}$sbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$scal( n, one / sigma, w, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$sbevd
#:endif
#:endfor
module subroutine stdlib${ii}$_ssbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! SSBEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric band matrix A. 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, 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, kd, ldab, 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,*)
real(sp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, &
iscale, itmp1, j, jj, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
tmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
tmp1 = ab( kd+1, 1_${ik}$ )
end if
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = tmp1
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if ( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
endif
anrm = stdlib${ii}$_slansb( 'M', uplo, n, kd, ab, ldab, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, work( indee ), info )
else
call stdlib${ii}$_slacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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, 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, vll, vuu, il, iu, abstll,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 orthogonal 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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_ssbevx
module subroutine stdlib${ii}$_dsbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! DSBEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric band matrix A. 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, 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, kd, ldab, 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,*)
real(dp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, &
iscale, itmp1, j, jj, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
tmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
tmp1 = ab( kd+1, 1_${ik}$ )
end if
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = tmp1
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_dlansb( 'M', uplo, n, kd, ab, ldab, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, work( indee ), info )
else
call stdlib${ii}$_dlacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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, 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}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal 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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_dsbevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$sbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! DSBEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric band matrix A. 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, 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, kd, ldab, 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,*)
real(${rk}$), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, &
iscale, itmp1, j, jj, nsplit
real(${rk}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
tmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
tmp1 = ab( kd+1, 1_${ik}$ )
end if
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = tmp1
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_${ri}$lansb( 'M', uplo, n, kd, ab, ldab, work )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ri}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ri}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ri}$sbtrd to reduce symmetric band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indwrk = inde + n
call stdlib${ii}$_${ri}$sbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_${ri}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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}$copy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ )
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, 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}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,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 orthogonal 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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${ri}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$sbevx
#:endif
#:endfor
module subroutine stdlib${ii}$_cheev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info )
!! CHEEV computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${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 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
work( 1_${ik}$ ) = 1_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_clascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_cungtr to generate the unitary matrix, then call stdlib${ii}$_csteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_cungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
indwrk = inde + n
call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cheev
module subroutine stdlib${ii}$_zheev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info )
!! ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${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 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
work( 1_${ik}$ ) = 1_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_zlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_zungtr to generate the unitary matrix, then call stdlib${ii}$_zsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_zungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
indwrk = inde + n
call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zheev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$heev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info )
!! ZHEEV: computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A.
! -- 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) :: lda, lwork, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${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 )*n )
work( 1_${ik}$ ) = lwkopt
if( lwork<max( 1_${ik}$, 2_${ik}$*n-1 ) .and. .not.lquery )info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEV ', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
work( 1_${ik}$ ) = 1_${ik}$
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_${ci}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ci}$ungtr to generate the unitary matrix, then 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}$ungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo )
indwrk = inde + n
call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$heev
#:endif
#:endfor
module subroutine stdlib${ii}$_cheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, liwork,&
!! CHEEVD computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A. 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) :: lda, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwk2, indwrk, iscale, liopt, &
liwmin, llrwk, llwork, llwrk2, lopt, lropt, lrwmin, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
lopt = lwmin
lropt = lrwmin
liopt = liwmin
else
if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = max( lwmin, n +stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lropt = lrwmin
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -10_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_clascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
indrwk = inde + n
indwk2 = indwrk + n*n
llwork = lwork - indwrk + 1_${ik}$
llwrk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_cstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_cunmtr to multiply it to the
! householder transformations represented as householder vectors in
! a.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_cstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), &
llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info )
call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_clacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_cheevd
module subroutine stdlib${ii}$_zheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, liwork,&
!! ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A. 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) :: lda, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwk2, indwrk, iscale, liopt, &
liwmin, llrwk, llwork, llwrk2, lopt, lropt, lrwmin, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
lopt = lwmin
lropt = lrwmin
liopt = liwmin
else
if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = max( lwmin, n +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lropt = lrwmin
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -10_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_zlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
indrwk = inde + n
indwk2 = indwrk + n*n
llwork = lwork - indwrk + 1_${ik}$
llwrk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_zstedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_zunmtr to multiply it to the
! householder transformations represented as householder vectors in
! a.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( inde ), info )
else
call stdlib${ii}$_zstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), &
llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info )
call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_zlacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_zheevd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$heevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, liwork,&
!! ZHEEVD: computes all eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix A. 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_${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) :: lda, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwk2, indwrk, iscale, liopt, &
liwmin, llrwk, llwork, llwrk2, lopt, lropt, lrwmin, lwmin
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( lda<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$
liwmin = 1_${ik}$
lopt = lwmin
lropt = lrwmin
liopt = liwmin
else
if( wantz ) then
lwmin = 2_${ik}$*n + n*n
lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
else
lwmin = n + 1_${ik}$
lrwmin = n
liwmin = 1_${ik}$
end if
lopt = max( lwmin, n +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lropt = lrwmin
liopt = liwmin
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
if( lwork<lwmin .and. .not.lquery ) then
info = -8_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -10_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -12_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
if( wantz )a( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhe( 'M', uplo, n, a, lda, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ )call stdlib${ii}$_${ci}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info )
! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indwrk = indtau + n
indrwk = inde + n
indwk2 = indwrk + n*n
llwork = lwork - indwrk + 1_${ik}$
llwrk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), &
llwork, iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ci}$stedc to generate the eigenvector matrix, work(indwrk), of the
! tridiagonal matrix, then call stdlib${ii}$_${ci}$unmtr to multiply it to the
! householder transformations represented as householder vectors in
! a.
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( indwrk ), n,work( indwk2 ), &
llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info )
call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, &
work( indwk2 ), llwrk2, iinfo )
call stdlib${ii}$_${ci}$lacpy( 'A', n, n, work( indwrk ), n, a, lda )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lopt
rwork( 1_${ik}$ ) = lropt
iwork( 1_${ik}$ ) = liopt
return
end subroutine stdlib${ii}$_${ci}$heevd
#:endif
#:endfor
module subroutine stdlib${ii}$_cheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! CHEEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! CHEEVR first reduces the matrix A to tridiagonal form T with a call
!! to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute
!! the eigenspectrum using Relatively Robust Representations. CSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see CSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of CSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: a(lda,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, &
indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, &
llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'CHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) )
lrwmin = max( 1_${ik}$, 24_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
lwmin = max( 1_${ik}$, 2_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${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}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -20_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -22_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 2_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
else
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_clansy( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_csscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_csscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_ssterf or stdlib${ii}$_cstemr fail.
! work(indtau:indtau+n-1) stores the complex scalar factors of the
! elementary reflectors used in stdlib${ii}$_chetrd.
indtau = 1_${ik}$
! indwk is the starting offset of the remaining complex workspace,
! and llwork is the remaining complex workspace size.
indwk = indtau + n
llwork = lwork - indwk + 1_${ik}$
! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal
! entries.
indrd = 1_${ik}$
! rwork(indre:indre+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_chetrd.
indre = indrd + n
! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_cstemr (the stdlib${ii}$_ssterf path copies the diagonal to w).
indrdd = indre + n
! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_ssterf and stdlib${ii}$_cstemr.
indree = indrdd + n
! indrwk is the starting offset of the left-over real workspace, and
! llrwork is the remaining workspace size.
indrwk = indree + n
llrwork = lrwork - indrwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_sstebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_sstebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_sstein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form.
call stdlib${ii}$_chetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), &
work( indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_ssterf or stdlib${ii}$_cstemr and stdlib${ii}$_cunmtr.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then
if( .not.wantz ) then
call stdlib${ii}$_scopy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_scopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, rwork( indree ), info )
else
call stdlib${ii}$_scopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_scopy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_cstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, &
iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_cstemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
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, stdlib${ii}$_cstein.
! also call stdlib${ii}$_sstebz and stdlib${ii}$_cstein if stdlib${ii}$_cstemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( &
indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )&
, info )
if( wantz ) then
call stdlib${ii}$_cstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_cstein.
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_cheevr
module subroutine stdlib${ii}$_zheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHEEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! ZHEEVR first reduces the matrix A to tridiagonal form T with a call
!! to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute
!! eigenspectrum using Relatively Robust Representations. ZSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see ZSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of ZSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: a(lda,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, &
indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, &
llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'ZHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) )
lrwmin = max( 1_${ik}$, 24_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
lwmin = max( 1_${ik}$, 2_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${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}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -20_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -22_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 2_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
else
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_zlansy( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_zdscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_zdscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_dsterf or stdlib${ii}$_zstemr fail.
! work(indtau:indtau+n-1) stores the complex scalar factors of the
! elementary reflectors used in stdlib${ii}$_zhetrd.
indtau = 1_${ik}$
! indwk is the starting offset of the remaining complex workspace,
! and llwork is the remaining complex workspace size.
indwk = indtau + n
llwork = lwork - indwk + 1_${ik}$
! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal
! entries.
indrd = 1_${ik}$
! rwork(indre:indre+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_zhetrd.
indre = indrd + n
! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_zstemr (the stdlib${ii}$_dsterf path copies the diagonal to w).
indrdd = indre + n
! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_dsterf and stdlib${ii}$_zstemr.
indree = indrdd + n
! indrwk is the starting offset of the left-over real workspace, and
! llrwork is the remaining workspace size.
indrwk = indree + n
llrwork = lrwork - indrwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_dstebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_dstebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_dstein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form.
call stdlib${ii}$_zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), &
work( indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_dsterf or stdlib${ii}$_zstemr and stdlib${ii}$_zunmtr.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_dcopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, rwork( indree ), info )
else
call stdlib${ii}$_dcopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_zstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, &
iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_zstemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
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, stdlib${ii}$_zstein.
! also call stdlib${ii}$_dstebz and stdlib${ii}$_zstein if stdlib${ii}$_zstemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( &
indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )&
, info )
if( wantz ) then
call stdlib${ii}$_zstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_zstein.
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zheevr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$heevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHEEVR: computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
!! ZHEEVR first reduces the matrix A to tridiagonal form T with a call
!! to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute
!! eigenspectrum using Relatively Robust Representations. ZSTEMR
!! computes eigenvalues by the dqds algorithm, while orthogonal
!! eigenvectors are computed from various "good" L D L^T representations
!! (also known as Relatively Robust Representations). Gram-Schmidt
!! orthogonalization is avoided as far as possible. More specifically,
!! the various steps of the algorithm are as follows.
!! For each unreduced block (submatrix) of T,
!! (a) Compute T - sigma I = L D L^T, so that L and D
!! define all the wanted eigenvalues to high relative accuracy.
!! This means that small relative changes in the entries of D and L
!! cause only small relative changes in the eigenvalues and
!! eigenvectors. The standard (unfactored) representation of the
!! tridiagonal matrix T does not have this property in general.
!! (b) Compute the eigenvalues to suitable accuracy.
!! If the eigenvectors are desired, the algorithm attains full
!! accuracy of the computed eigenvalues only right before
!! the corresponding vectors have to be computed, see steps c) and d).
!! (c) For each cluster of close eigenvalues, select a new
!! shift close to the cluster, find a new factorization, and refine
!! the shifted eigenvalues to suitable accuracy.
!! (d) For each eigenvalue with a large enough relative separation compute
!! the corresponding eigenvector by forming a rank revealing twisted
!! factorization. Go back to (c) for any clusters that remain.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see ZSTEMR's documentation and:
!! - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
!! to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
!! Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
!! - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
!! Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
!! 2004. Also LAPACK Working Note 154.
!! - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem",
!! Computer Science Division Technical Report No. UCB/CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and
!! when partial spectrum requests are made.
!! Normal execution of ZSTEMR may create NaNs and infinities and
!! hence may abort due to a floating point exception in environments
!! which do not handle NaNs and infinities in the ieee standard default
!! manner.
isuppz, work, 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, range, uplo
integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${ck}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: a(lda,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, &
indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, &
llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit
real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'ZHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
lower = stdlib_lsame( uplo, 'L' )
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) )
lrwmin = max( 1_${ik}$, 24_${ik}$*n )
liwmin = max( 1_${ik}$, 10_${ik}$*n )
lwmin = max( 1_${ik}$, 2_${ik}$*n )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${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}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( ( nb+1 )*n, lwmin )
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -18_${ik}$
else if( lrwork<lrwmin .and. .not.lquery ) then
info = -20_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -22_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVR', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
work( 1_${ik}$ ) = 1_${ik}$
return
end if
if( n==1_${ik}$ ) then
work( 1_${ik}$ ) = 2_${ik}$
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
else
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
end if
end if
if( wantz ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz( 1_${ik}$ ) = 1_${ik}$
isuppz( 2_${ik}$ ) = 1_${ik}$
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if (valeig) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_${ci}$lansy( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_${ci}$dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: the iwork indices are
! used only if stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$stemr fail.
! work(indtau:indtau+n-1) stores the complex scalar factors of the
! elementary reflectors used in stdlib${ii}$_${ci}$hetrd.
indtau = 1_${ik}$
! indwk is the starting offset of the remaining complex workspace,
! and llwork is the remaining complex workspace size.
indwk = indtau + n
llwork = lwork - indwk + 1_${ik}$
! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal
! entries.
indrd = 1_${ik}$
! rwork(indre:indre+n-1) stores the off-diagonal entries of the
! tridiagonal matrix from stdlib${ii}$_${ci}$hetrd.
indre = indrd + n
! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over
! -written by stdlib${ii}$_${ci}$stemr (the stdlib${ii}$_${c2ri(ci)}$sterf path copies the diagonal to w).
indrdd = indre + n
! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over
! -written while computing the eigenvalues in stdlib${ii}$_${c2ri(ci)}$sterf and stdlib${ii}$_${ci}$stemr.
indree = indrdd + n
! indrwk is the starting offset of the left-over real workspace, and
! llrwork is the remaining workspace size.
indrwk = indree + n
llrwork = lrwork - indrwk + 1_${ik}$
! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_${c2ri(ci)}$stebz and
! stores the block indices of each of the m<=n eigenvalues.
indibl = 1_${ik}$
! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_${c2ri(ci)}$stebz and
! stores the starting and finishing indices of each block.
indisp = indibl + n
! iwork(indifl:indifl+n-1) stores the indices of eigenvectors
! that corresponding to eigenvectors that fail to converge in
! stdlib${ii}$_${c2ri(ci)}$stein. this information is discarded; if any fail, the driver
! returns info > 0.
indifl = indisp + n
! indiwo is the offset of the remaining integer workspace.
indiwo = indifl + n
! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form.
call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), &
work( indwk ), llwork, iinfo )
! if all eigenvalues are desired
! then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$stemr and stdlib${ii}$_${ci}$unmtr.
test = .false.
if( indeig ) then
if( il==1_${ik}$ .and. iu==n ) then
test = .true.
end if
end if
if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indree ), info )
else
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_${ci}$stemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, &
iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ci}$stemr.
if( wantz .and. info==0_${ik}$ ) then
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(&
indwkn ),llwrkn, iinfo )
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, stdlib${ii}$_${ci}$stein.
! also call stdlib${ii}$_${c2ri(ci)}$stebz and stdlib${ii}$_${ci}$stein if stdlib${ii}$_${ci}$stemr fails.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( &
indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )&
, info )
if( wantz ) then
call stdlib${ii}$_${ci}$stein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( &
indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info )
! apply unitary matrix used in reduction to tridiagonal
! form to eigenvectors returned by stdlib${ii}$_${ci}$stein.
indwkn = indwk
llwrkn = lwork - indwkn + 1_${ik}$
call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwkn ), llwrkn, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$ )
end if
end do
end if
! set work(1) to optimal workspace size.
work( 1_${ik}$ ) = lwkopt
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$heevr
#:endif
#:endfor
module subroutine stdlib${ii}$_cheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! CHEEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, iu, lda, 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,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, llwork, lwkmin, lwkopt, nb, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 2_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
else if( valeig ) then
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_clanhe( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_csscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_csscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_chetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(&
indwrk ), llwork, iinfo )
! if all eigenvalues are desired and abstol is less than or equal to
! zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_cungtr and 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_clacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_cungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwrk ), llwork, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_cheevx
module subroutine stdlib${ii}$_zheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, iu, lda, 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,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, llwork, lwkmin, lwkopt, nb, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 2_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
else if( valeig ) then
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_zlanhe( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_zdscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_zdscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_zhetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(&
indwrk ), llwork, iinfo )
! if all eigenvalues are desired and abstol is less than or equal to
! zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zungtr and 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_zlacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_zungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwrk ), llwork, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_zheevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$heevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHEEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
!! be selected by specifying either a range of values or a range of
!! indices for the desired eigenvalues.
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, iu, lda, 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,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, llwork, lwkmin, lwkopt, nb, nsplit
real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
lower = stdlib_lsame( uplo, 'L' )
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( .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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -10_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -15_${ik}$
end if
end if
if( info==0_${ik}$ ) then
if( n<=1_${ik}$ ) then
lwkmin = 1_${ik}$
work( 1_${ik}$ ) = lwkmin
else
lwkmin = 2_${ik}$*n
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRD', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMTR', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) )
lwkopt = max( 1_${ik}$, ( nb + 1_${ik}$ )*n )
work( 1_${ik}$ ) = lwkopt
end if
if( lwork<lwkmin .and. .not.lquery )info = -17_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHEEVX', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0_${ik}$ ) then
return
end if
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
else if( valeig ) then
if( vl<real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) .and. vu>=real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) )then
m = 1_${ik}$
w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
end if
anrm = stdlib${ii}$_${ci}$lanhe( 'M', uplo, n, a, lda, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
do j = 1, n
call stdlib${ii}$_${ci}$dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ )
end do
else
do j = 1, n
call stdlib${ii}$_${ci}$dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
llwork = lwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(&
indwrk ), llwork, 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}$ungtr and 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
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_${ci}$lacpy( 'A', n, n, a, lda, z, ldz )
call stdlib${ii}$_${ci}$ungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, &
iinfo )
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 40
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( &
indwrk ), llwork, iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
40 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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
! set work(1) to optimal complex workspace size.
work( 1_${ik}$ ) = lwkopt
return
end subroutine stdlib${ii}$_${ci}$heevx
#:endif
#:endfor
module subroutine stdlib${ii}$_chpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info )
!! CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp)
rwork( 1_${ik}$ ) = 1_${ik}$
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
call stdlib${ii}$_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_cupgtr to generate the orthogonal matrix, then call stdlib${ii}$_csteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, rwork( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
indrwk = inde + n
call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_chpev
module subroutine stdlib${ii}$_zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info )
!! ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp)
rwork( 1_${ik}$ ) = 1_${ik}$
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
call stdlib${ii}$_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_zupgtr to generate the orthogonal matrix, then call stdlib${ii}$_zsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, rwork( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
indrwk = inde + n
call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zhpev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info )
!! ZHPEV: computes all the eigenvalues and, optionally, eigenvectors of a
!! complex Hermitian matrix in packed storage.
! -- 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) :: ldz, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$)
rwork( 1_${ik}$ ) = 1_${ik}$
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ci}$upgtr to generate the orthogonal matrix, then call stdlib${ii}$_${ci}$steqr.
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info )
else
indwrk = indtau + n
call stdlib${ii}$_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
indrwk = inde + n
call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$hpev
#:endif
#:endfor
module subroutine stdlib${ii}$_chpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, &
!! CHPEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian matrix A in packed storage. 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.
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) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ap(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale, liwmin, llrwk, &
llwrk, lrwmin, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 = -9_${ik}$
else if( lrwork<lrwmin .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( 'CHPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indrwk = inde + n
indwrk = indtau + n
llwrk = lwork - indwrk + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call
! stdlib${ii}$_cupgtr to generate the orthogonal matrix, then 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 ), z, ldz, work( indwrk ),llwrk, rwork( &
indrwk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_cupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_chpevd
module subroutine stdlib${ii}$_zhpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, &
!! ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian matrix A in packed storage. 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.
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) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ap(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale, liwmin, llrwk, &
llwrk, lrwmin, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 = -9_${ik}$
else if( lrwork<lrwmin .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( 'ZHPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indrwk = inde + n
indwrk = indtau + n
llwrk = lwork - indwrk + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call
! stdlib${ii}$_zupgtr to generate the orthogonal matrix, then 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 ), z, ldz, work( indwrk ),llwrk, rwork( &
indrwk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_zupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zhpevd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, &
!! ZHPEVD: computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian matrix A in packed storage. 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.
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) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ap(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale, liwmin, llrwk, &
llwrk, lrwmin, lwmin
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -7_${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 = -9_${ik}$
else if( lrwork<lrwmin .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( 'ZHPEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhp( 'M', uplo, n, ap, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
end if
! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form.
inde = 1_${ik}$
indtau = 1_${ik}$
indrwk = inde + n
indwrk = indtau + n
llwrk = lwork - indwrk + 1_${ik}$
llrwk = lrwork - indrwk + 1_${ik}$
call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo )
! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call
! stdlib${ii}$_${ci}$upgtr to generate the orthogonal matrix, then 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 ), z, ldz, work( indwrk ),llwrk, rwork( &
indrwk ), llrwk, iwork, liwork,info )
call stdlib${ii}$_${ci}$upmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$hpevd
#:endif
#:endfor
module subroutine stdlib${ii}$_chpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! CHPEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A in packed storage.
!! Eigenvalues/vectors can be selected by specifying either a range of
!! values or a range of indices for the desired eigenvalues.
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, 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(*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp)
else
if( vl<real( ap( 1_${ik}$ ),KIND=sp) .and. vu>=real( ap( 1_${ik}$ ),KIND=sp) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if ( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
endif
anrm = stdlib${ii}$_clanhp( 'M', uplo, n, ap, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
call stdlib${ii}$_chptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_cupgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
indwrk = indtau + n
call stdlib${ii}$_cupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_chpevx
module subroutine stdlib${ii}$_zhpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHPEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A in packed storage.
!! Eigenvalues/vectors can be selected by specifying either a range of
!! values or a range of indices for the desired eigenvalues.
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, 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(*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp)
else
if( vl<real( ap( 1_${ik}$ ),KIND=dp) .and. vu>=real( ap( 1_${ik}$ ),KIND=dp) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_zlanhp( 'M', uplo, n, ap, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
call stdlib${ii}$_zhptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo )
! if all eigenvalues are desired and abstol is less than or equal
! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zupgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
indwrk = indtau + n
call stdlib${ii}$_zupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_zhpevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZHPEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian matrix A in packed storage.
!! Eigenvalues/vectors can be selected by specifying either a range of
!! values or a range of indices for the desired eigenvalues.
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, 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(*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indtau, indwrk, iscale, itmp1, j, jj, nsplit
real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
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.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )&
then
info = -3_${ik}$
else if( n<0_${ik}$ ) then
info = -4_${ik}$
else
if( valeig ) then
if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$
else if( indeig ) then
if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then
info = -8_${ik}$
else if( iu<min( n, il ) .or. iu>n ) then
info = -9_${ik}$
end if
end if
end if
if( info==0_${ik}$ ) then
if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) )info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHPEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$)
else
if( vl<real( ap( 1_${ik}$ ),KIND=${ck}$) .and. vu>=real( ap( 1_${ik}$ ),KIND=${ck}$) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$)
end if
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_${ci}$lanhp( 'M', uplo, n, ap, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ )
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indtau = 1_${ik}$
indwrk = indtau + n
call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), 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}$upgtr and 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
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo )
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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 20
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, 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, vll, vuu, il, iu, abstll,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.
indwrk = indtau + n
call stdlib${ii}$_${ci}$upmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),&
iinfo )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
20 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$hpevx
#:endif
#:endfor
module subroutine stdlib${ii}$_chbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info )
!! CHBEV computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ab(ldab,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'CHBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=sp)
else
w( 1_${ik}$ ) = real( ab( kd+1, 1_${ik}$ ),KIND=sp)
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, 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
indrwk = inde + n
call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_chbev
module subroutine stdlib${ii}$_zhbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info )
!! ZHBEV computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ab(ldab,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'ZHBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=dp)
else
w( 1_${ik}$ ) = real( ab( kd+1, 1_${ik}$ ),KIND=dp)
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, 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
indrwk = inde + n
call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_zhbev
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info )
!! ZHBEV: computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A.
! -- 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) :: kd, ldab, ldz, n
! Array Arguments
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, wantz
integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
info = 0_${ik}$
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${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( 'ZHBEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( lower ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
else
w( 1_${ik}$ ) = real( ab( kd+1, 1_${ik}$ ),KIND=${ck}$)
end if
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, 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
indrwk = inde + n
call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ci}$hbev
#:endif
#:endfor
module subroutine stdlib${ii}$_chbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, &
!! CHBEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A. 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) :: kd, ldab, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(out) :: rwork(*), w(*)
complex(sp), intent(inout) :: ab(ldab,*)
complex(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, &
lrwmin, lwmin
real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-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**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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${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 = -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( 'CHBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=sp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_clanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indwrk + 1_${ik}$
call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_chbevd
module subroutine stdlib${ii}$_zhbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, &
!! ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A. 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) :: kd, ldab, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(out) :: rwork(*), w(*)
complex(dp), intent(inout) :: ab(ldab,*)
complex(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, &
lrwmin, lwmin
real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-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**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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${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 = -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( 'ZHBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=dp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_zlanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indwrk + 1_${ik}$
call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zhbevd
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, &
!! ZHBEVD: computes all the eigenvalues and, optionally, eigenvectors of
!! a complex Hermitian band matrix A. 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) :: kd, ldab, ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(out) :: rwork(*), w(*)
complex(${ck}$), intent(inout) :: ab(ldab,*)
complex(${ck}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lower, lquery, wantz
integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, &
lrwmin, lwmin
real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lower = stdlib_lsame( uplo, 'L' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-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**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
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( kd<0_${ik}$ ) then
info = -4_${ik}$
else if( ldab<kd+1 ) then
info = -6_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -9_${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 = -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( 'ZHBEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = sqrt( bignum )
! scale matrix to allowable range, if necessary.
anrm = stdlib${ii}$_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork )
iscale = 0_${ik}$
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
end if
! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form.
inde = 1_${ik}$
indwrk = inde + n
indwk2 = 1_${ik}$ + n*n
llwk2 = lwork - indwk2 + 1_${ik}$
llrwk = lrwork - indwrk + 1_${ik}$
call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, 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
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = n
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$hbevd
#:endif
#:endfor
module subroutine stdlib${ii}$_chbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! CHBEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian band matrix A. 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, 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, kd, ldab, 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,*)
complex(sp), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indwrk, iscale, itmp1, j, jj, nsplit
real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
complex(sp) :: ctmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CHBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
ctmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
ctmp1 = ab( kd+1, 1_${ik}$ )
end if
tmp1 = real( ctmp1,KIND=sp)
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ctmp1,KIND=sp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_slamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if ( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
endif
anrm = stdlib${ii}$_clanhb( 'M', uplo, n, kd, ab, ldab, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_clacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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, 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, vll, vuu, il, iu, abstll,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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_chbevx
module subroutine stdlib${ii}$_zhbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! ZHBEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian band matrix A. 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, 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, kd, ldab, 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,*)
complex(dp), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indwrk, iscale, itmp1, j, jj, nsplit
real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
complex(dp) :: ctmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
ctmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
ctmp1 = ab( kd+1, 1_${ik}$ )
end if
tmp1 = real( ctmp1,KIND=dp)
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ctmp1,KIND=dp)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_dlamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_zlanhb( 'M', uplo, n, kd, ab, ldab, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, rwork( indee ), info )
else
call stdlib${ii}$_zlacpy( 'A', n, n, q, ldq, z, ldz )
call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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, 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, vll, vuu, il, iu, abstll,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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$_zhbevx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$hbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, &
!! ZHBEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a complex Hermitian band matrix A. 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, 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, kd, ldab, 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,*)
complex(${ck}$), intent(out) :: q(ldq,*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, lower, test, valeig, wantz
character :: order
integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, &
indwrk, iscale, itmp1, j, jj, nsplit
real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, &
vuu
complex(${ck}$) :: ctmp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
alleig = stdlib_lsame( range, 'A' )
valeig = stdlib_lsame( range, 'V' )
indeig = stdlib_lsame( range, 'I' )
lower = stdlib_lsame( uplo, 'L' )
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.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( wantz .and. ldq<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 ) )info = -18_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZHBEVX', -info )
return
end if
! quick return if possible
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
m = 1_${ik}$
if( lower ) then
ctmp1 = ab( 1_${ik}$, 1_${ik}$ )
else
ctmp1 = ab( kd+1, 1_${ik}$ )
end if
tmp1 = real( ctmp1,KIND=${ck}$)
if( valeig ) then
if( .not.( vl<tmp1 .and. vu>=tmp1 ) )m = 0_${ik}$
end if
if( m==1_${ik}$ ) then
w( 1_${ik}$ ) = real( ctmp1,KIND=${ck}$)
if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone
end if
return
end if
! get machine constants.
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
smlnum = safmin / eps
bignum = one / smlnum
rmin = sqrt( smlnum )
rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) )
! scale matrix to allowable range, if necessary.
iscale = 0_${ik}$
abstll = abstol
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
anrm = stdlib${ii}$_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork )
if( anrm>zero .and. anrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / anrm
else if( anrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / anrm
end if
if( iscale==1_${ik}$ ) then
if( lower ) then
call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info )
else
call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info )
end if
if( abstol>0_${ik}$ )abstll = abstol*sigma
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form.
indd = 1_${ik}$
inde = indd + n
indrwk = inde + n
indwrk = 1_${ik}$
call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, 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
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ )
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, 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, vll, vuu, il, iu, abstll,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
! if matrix was scaled, then rescale eigenvalues appropriately.
30 continue
if( iscale==1_${ik}$ ) then
if( info==0_${ik}$ ) then
imax = m
else
imax = info - 1_${ik}$
end if
call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ )
end if
! 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}$hbevx
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_std_driver
