#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_tridiag3
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_sstev( jobz, n, d, e, z, ldz, work, info )
!! SSTEV computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: imax, iscale
real(sp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! 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( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_ssteqr.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, d, e, info )
else
call stdlib${ii}$_ssteqr( 'I', n, d, e, z, ldz, work, 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, d, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_sstev
pure module subroutine stdlib${ii}$_dstev( jobz, n, d, e, z, ldz, work, info )
!! DSTEV computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: imax, iscale
real(dp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! 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( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_dsteqr.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, d, e, info )
else
call stdlib${ii}$_dsteqr( 'I', n, d, e, z, ldz, work, 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, d, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_dstev
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stev( jobz, n, d, e, z, ldz, work, info )
!! DSTEV: computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: d(*), e(*)
real(${rk}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: wantz
integer(${ik}$) :: imax, iscale
real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! 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( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEV ', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_${ri}$steqr.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, d, e, info )
else
call stdlib${ii}$_${ri}$steqr( 'I', n, d, e, z, ldz, work, 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, d, 1_${ik}$ )
end if
return
end subroutine stdlib${ii}$_${ri}$stev
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal matrix. 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iscale, liwmin, lwmin
real(sp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
liwmin = 1_${ik}$
lwmin = 1_${ik}$
if( n>1_${ik}$ .and. wantz ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'SSTEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_sstedc.
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, d, e, info )
else
call stdlib${ii}$_sstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, d, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sstevd
pure module subroutine stdlib${ii}$_dstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal matrix. 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iscale, liwmin, lwmin
real(dp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
liwmin = 1_${ik}$
lwmin = 1_${ik}$
if( n>1_${ik}$ .and. wantz ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'DSTEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_dstedc.
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, d, e, info )
else
call stdlib${ii}$_dstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, d, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dstevd
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! DSTEVD: computes all eigenvalues and, optionally, eigenvectors of a
!! real symmetric tridiagonal matrix. 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
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: d(*), e(*)
real(${rk}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery, wantz
integer(${ik}$) :: iscale, liwmin, lwmin
real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm
! Intrinsic Functions
! Executable Statements
! test the input parameters.
wantz = stdlib_lsame( jobz, 'V' )
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
info = 0_${ik}$
liwmin = 1_${ik}$
lwmin = 1_${ik}$
if( n>1_${ik}$ .and. wantz ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'DSTEVD', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
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.
iscale = 0_${ik}$
tnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
end if
! for eigenvalues only, call stdlib${ii}$_${ri}$sterf. for eigenvalues and
! eigenvectors, call stdlib${ii}$_${ri}$stedc.
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, d, e, info )
else
call stdlib${ii}$_${ri}$stedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$scal( n, one / sigma, d, 1_${ik}$ )
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$stevd
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! SSTEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Eigenvalues and
!! eigenvectors can be selected by specifying either a range of values
!! or a range of indices for the desired eigenvalues.
!! Whenever possible, SSTEVR 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 the i-th
!! unreduced block of T,
!! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!! is a relatively robust representation,
!! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!! relative accuracy by the dqds algorithm,
!! (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!! close to the cluster, and go to step (a),
!! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!! compute the corresponding eigenvector by forming a
!! rank-revealing twisted factorization.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!! Computer Science Division Technical Report No. UCB//CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! SSTEVR 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
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, lquery, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, imax, indibl, indifl, indisp, indiwo, iscale, j, jj, liwmin,&
lwmin, nsplit
real(sp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'SSTEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
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}$, 20_${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( n<0_${ik}$ ) then
info = -3_${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 ) ) then
info = -14_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEVR', -info )
return
else if( lquery ) then
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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if( valeig ) then
vll = vl
vuu = vu
end if
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: these indices are used only
! if stdlib${ii}$_ssterf or stdlib${ii}$_sstemr fail.
! 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 = indisp + n
! if all eigenvalues are desired, then
! call stdlib${ii}$_ssterf or stdlib${ii}$_sstemr. 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. ieeeok==1_${ik}$ ) then
call stdlib${ii}$_scopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_scopy( n, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_ssterf( n, w, work, info )
else
call stdlib${ii}$_scopy( n, d, 1_${ik}$, work( n+1 ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_sstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,&
n, isuppz, tryrac,work( 2_${ik}$*n+1 ), lwork-2*n, iwork, liwork, info )
end if
if( info==0_${ik}$ ) then
m = n
go to 10
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
call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, &
iwork( indiwo ), iwork( indifl ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
10 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
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
! causes problems with tests 19
! if (wantz .and. indeig ) z( 1,1) = z(1,1) / 1.002_sp + .002
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sstevr
pure module subroutine stdlib${ii}$_dstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! DSTEVR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Eigenvalues and
!! eigenvectors can be selected by specifying either a range of values
!! or a range of indices for the desired eigenvalues.
!! Whenever possible, DSTEVR 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 the i-th
!! unreduced block of T,
!! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!! is a relatively robust representation,
!! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!! relative accuracy by the dqds algorithm,
!! (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!! close to the cluster, and go to step (a),
!! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!! compute the corresponding eigenvector by forming a
!! rank-revealing twisted factorization.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!! Computer Science Division Technical Report No. UCB//CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! DSTEVR 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
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, lquery, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, imax, indibl, indifl, indisp, indiwo, iscale, itmp1, j, jj, &
liwmin, lwmin, nsplit
real(dp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'DSTEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
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}$, 20_${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( n<0_${ik}$ ) then
info = -3_${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 ) ) then
info = -14_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEVR', -info )
return
else if( lquery ) then
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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if( valeig ) then
vll = vl
vuu = vu
end if
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: these indices are used only
! if stdlib${ii}$_dsterf or stdlib${ii}$_dstemr fail.
! 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 = indisp + n
! if all eigenvalues are desired, then
! call stdlib${ii}$_dsterf or stdlib${ii}$_dstemr. 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. ieeeok==1_${ik}$ ) then
call stdlib${ii}$_dcopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_dcopy( n, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_dsterf( n, w, work, info )
else
call stdlib${ii}$_dcopy( n, d, 1_${ik}$, work( n+1 ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_dstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,&
n, isuppz, tryrac,work( 2_${ik}$*n+1 ), lwork-2*n, iwork, liwork, info )
end if
if( info==0_${ik}$ ) then
m = n
go to 10
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_dstein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_dstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, &
iwork( indiwo ), iwork( indifl ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
10 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( i )
w( i ) = w( j )
iwork( i ) = iwork( j )
w( j ) = tmp1
iwork( j ) = itmp1
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
end if
end do
end if
! causes problems with tests 19
! if (wantz .and. indeig ) z( 1,1) = z(1,1) / 1.002_dp + .002
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dstevr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! DSTEVR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Eigenvalues and
!! eigenvectors can be selected by specifying either a range of values
!! or a range of indices for the desired eigenvalues.
!! Whenever possible, DSTEVR 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 the i-th
!! unreduced block of T,
!! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
!! is a relatively robust representation,
!! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
!! relative accuracy by the dqds algorithm,
!! (c) If there is a cluster of close eigenvalues, "choose" sigma_i
!! close to the cluster, and go to step (a),
!! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
!! compute the corresponding eigenvector by forming a
!! rank-revealing twisted factorization.
!! The desired accuracy of the output can be specified by the input
!! parameter ABSTOL.
!! For more details, see "A new O(n^2) algorithm for the symmetric
!! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
!! Computer Science Division Technical Report No. UCB//CSD-97-971,
!! UC Berkeley, May 1997.
!! Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
!! on machines which conform to the ieee-754 floating point standard.
!! DSTEVR 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
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, lquery, valeig, wantz, tryrac
character :: order
integer(${ik}$) :: i, ieeeok, imax, indibl, indifl, indisp, indiwo, iscale, itmp1, j, jj, &
liwmin, lwmin, nsplit
real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, &
vuu
! Intrinsic Functions
! Executable Statements
! test the input parameters.
ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'DSTEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ )
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}$, 20_${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( n<0_${ik}$ ) then
info = -3_${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 ) ) then
info = -14_${ik}$
end if
end if
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEVR', -info )
return
else if( lquery ) then
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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if( valeig ) then
vll = vl
vuu = vu
end if
tnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! initialize indices into workspaces. note: these indices are used only
! if stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$stemr fail.
! 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 = indisp + n
! if all eigenvalues are desired, then
! call stdlib${ii}$_${ri}$sterf or stdlib${ii}$_${ri}$stemr. 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. ieeeok==1_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
if( .not.wantz ) then
call stdlib${ii}$_${ri}$copy( n, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_${ri}$sterf( n, w, work, info )
else
call stdlib${ii}$_${ri}$copy( n, d, 1_${ik}$, work( n+1 ), 1_${ik}$ )
if (abstol <= two*n*eps) then
tryrac = .true.
else
tryrac = .false.
end if
call stdlib${ii}$_${ri}$stemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,&
n, isuppz, tryrac,work( 2_${ik}$*n+1 ), lwork-2*n, iwork, liwork, info )
end if
if( info==0_${ik}$ ) then
m = n
go to 10
end if
info = 0_${ik}$
end if
! otherwise, call stdlib${ii}$_${ri}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ri}$stein.
if( wantz ) then
order = 'B'
else
order = 'E'
end if
call stdlib${ii}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_${ri}$stein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, &
iwork( indiwo ), iwork( indifl ),info )
end if
! if matrix was scaled, then rescale eigenvalues appropriately.
10 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( i )
w( i ) = w( j )
iwork( i ) = iwork( j )
w( j ) = tmp1
iwork( j ) = itmp1
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
end if
end do
end if
! causes problems with tests 19
! if (wantz .and. indeig ) z( 1,1) = z(1,1) / 1.002_${rk}$ + .002
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$stevr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstevx( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! SSTEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal 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, 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
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) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, imax, indibl, indisp, indiwo, indwrk, iscale, itmp1, j, jj, &
nsplit
real(sp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, 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( n<0_${ik}$ ) then
info = -3_${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( 'SSTEVX', -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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if ( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
endif
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! if all eigenvalues are desired and abstol is less than 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, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_scopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
indwrk = n + 1_${ik}$
if( .not.wantz ) then
call stdlib${ii}$_ssterf( n, w, work, info )
else
call stdlib${ii}$_ssteqr( 'I', n, w, work, 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
indwrk = 1_${ik}$
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ),work( indwrk ), iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work( &
indwrk ), iwork( indiwo ), ifail,info )
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}$_sstevx
pure module subroutine stdlib${ii}$_dstevx( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! DSTEVX computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal 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, 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
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) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, imax, indibl, indisp, indiwo, indwrk, iscale, itmp1, j, jj, &
nsplit
real(dp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, 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( n<0_${ik}$ ) then
info = -3_${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( 'DSTEVX', -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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! if all eigenvalues are desired and abstol is less than 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, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_dcopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
indwrk = n + 1_${ik}$
if( .not.wantz ) then
call stdlib${ii}$_dsterf( n, w, work, info )
else
call stdlib${ii}$_dsteqr( 'I', n, w, work, 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
indwrk = 1_${ik}$
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ),work( indwrk ), iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_dstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work( &
indwrk ), iwork( indiwo ), ifail,info )
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}$_dstevx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stevx( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, &
!! DSTEVX: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal 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, 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
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) :: d(*), e(*)
real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: alleig, indeig, test, valeig, wantz
character :: order
integer(${ik}$) :: i, imax, indibl, indisp, indiwo, indwrk, iscale, itmp1, j, jj, &
nsplit
real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, 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( n<0_${ik}$ ) then
info = -3_${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( 'DSTEVX', -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}$ ) = d( 1_${ik}$ )
else
if( vl<d( 1_${ik}$ ) .and. vu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 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}$
if( valeig ) then
vll = vl
vuu = vu
else
vll = zero
vuu = zero
end if
tnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
iscale = 1_${ik}$
sigma = rmin / tnrm
else if( tnrm>rmax ) then
iscale = 1_${ik}$
sigma = rmax / tnrm
end if
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$scal( n, sigma, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ )
if( valeig ) then
vll = vl*sigma
vuu = vu*sigma
end if
end if
! if all eigenvalues are desired and abstol is less than 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, d, 1_${ik}$, w, 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ )
indwrk = n + 1_${ik}$
if( .not.wantz ) then
call stdlib${ii}$_${ri}$sterf( n, w, work, info )
else
call stdlib${ii}$_${ri}$steqr( 'I', n, w, work, 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
indwrk = 1_${ik}$
indibl = 1_${ik}$
indisp = indibl + n
indiwo = indisp + n
call stdlib${ii}$_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, &
iwork( indibl ), iwork( indisp ),work( indwrk ), iwork( indiwo ), info )
if( wantz ) then
call stdlib${ii}$_${ri}$stein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work( &
indwrk ), iwork( indiwo ), ifail,info )
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}$stevx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_spteqr( compz, n, d, e, z, ldz, work, info )
!! SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using SPTTRF, and then calling SBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band symmetric positive definite matrix
!! can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to tridiagonal
!! form, however, may preclude the possibility of obtaining high
!! relative accuracy in the small eigenvalues of the original matrix, if
!! these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*), z(ldz,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Arrays
real(sp) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, z, ldz )
! call stdlib${ii}$_spttrf to factor the matrix.
call stdlib${ii}$_spttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_sbdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_sbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_spteqr
pure module subroutine stdlib${ii}$_dpteqr( compz, n, d, e, z, ldz, work, info )
!! DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using DPTTRF, and then calling DBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band symmetric positive definite matrix
!! can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to tridiagonal
!! form, however, may preclude the possibility of obtaining high
!! relative accuracy in the small eigenvalues of the original matrix, if
!! these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*), z(ldz,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Arrays
real(dp) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, z, ldz )
! call stdlib${ii}$_dpttrf to factor the matrix.
call stdlib${ii}$_dpttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_dbdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_dbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_dpteqr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$pteqr( compz, n, d, e, z, ldz, work, info )
!! DPTEQR: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using DPTTRF, and then calling DBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band symmetric positive definite matrix
!! can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to tridiagonal
!! form, however, may preclude the possibility of obtaining high
!! relative accuracy in the small eigenvalues of the original matrix, if
!! these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: d(*), e(*), z(ldz,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Arrays
real(${rk}$) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, z, ldz )
! call stdlib${ii}$_${ri}$pttrf to factor the matrix.
call stdlib${ii}$_${ri}$pttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_${ri}$bdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_${ri}$bdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_${ri}$pteqr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cpteqr( compz, n, d, e, z, ldz, work, info )
!! CPTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using SPTTRF and then calling CBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band positive definite Hermitian matrix
!! can also be found if CHETRD, CHPTRD, or CHBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to
!! tridiagonal form, however, may preclude the possibility of obtaining
!! high relative accuracy in the small eigenvalues of the original
!! matrix, if these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: z(ldz,*)
! ====================================================================
! Local Arrays
complex(sp) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, z, ldz )
! call stdlib${ii}$_spttrf to factor the matrix.
call stdlib${ii}$_spttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_cbdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_cbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_cpteqr
pure module subroutine stdlib${ii}$_zpteqr( compz, n, d, e, z, ldz, work, info )
!! ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using DPTTRF and then calling ZBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band positive definite Hermitian matrix
!! can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to
!! tridiagonal form, however, may preclude the possibility of obtaining
!! high relative accuracy in the small eigenvalues of the original
!! matrix, if these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: z(ldz,*)
! ====================================================================
! Local Arrays
complex(dp) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, z, ldz )
! call stdlib${ii}$_dpttrf to factor the matrix.
call stdlib${ii}$_dpttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_zbdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_zbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_zpteqr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$pteqr( compz, n, d, e, z, ldz, work, info )
!! ZPTEQR: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric positive definite tridiagonal matrix by first factoring the
!! matrix using DPTTRF and then calling ZBDSQR to compute the singular
!! values of the bidiagonal factor.
!! This routine computes the eigenvalues of the positive definite
!! tridiagonal matrix to high relative accuracy. This means that if the
!! eigenvalues range over many orders of magnitude in size, then the
!! small eigenvalues and corresponding eigenvectors will be computed
!! more accurately than, for example, with the standard QR method.
!! The eigenvectors of a full or band positive definite Hermitian matrix
!! can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to
!! reduce this matrix to tridiagonal form. (The reduction to
!! tridiagonal form, however, may preclude the possibility of obtaining
!! high relative accuracy in the small eigenvalues of the original
!! matrix, if these eigenvalues range over many orders of magnitude.)
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(${ck}$), intent(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: z(ldz,*)
! ====================================================================
! Local Arrays
complex(${ck}$) :: c(1_${ik}$,1_${ik}$), vt(1_${ik}$,1_${ik}$)
! Local Scalars
integer(${ik}$) :: i, icompz, nru
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZPTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
if( icompz==2_${ik}$ )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz )
! call stdlib${ii}$_${c2ri(ci)}$pttrf to factor the matrix.
call stdlib${ii}$_${c2ri(ci)}$pttrf( n, d, e, info )
if( info/=0 )return
do i = 1, n
d( i ) = sqrt( d( i ) )
end do
do i = 1, n - 1
e( i ) = e( i )*d( i )
end do
! call stdlib${ii}$_${ci}$bdsqr to compute the singular values/vectors of the
! bidiagonal factor.
if( icompz>0_${ik}$ ) then
nru = n
else
nru = 0_${ik}$
end if
call stdlib${ii}$_${ci}$bdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info )
! square the singular values.
if( info==0_${ik}$ ) then
do i = 1, n
d( i ) = d( i )*d( i )
end do
else
info = n + info
end if
return
end subroutine stdlib${ii}$_${ci}$pteqr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w, &
!! SSTEBZ computes the eigenvalues of a symmetric tridiagonal
!! matrix T. The user may ask for all eigenvalues, all eigenvalues
!! in the half-open interval (VL, VU], or the IL-th through IU-th
!! eigenvalues.
!! To avoid overflow, the matrix must be scaled so that its
!! largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!! accuracy, it should not be much smaller than that.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966.
iblock, isplit, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: order, range
integer(${ik}$), intent(in) :: il, iu, n
integer(${ik}$), intent(out) :: info, m, nsplit
real(sp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: iblock(*), isplit(*), iwork(*)
real(sp), intent(in) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
real(sp), parameter :: fudge = 2.1_sp
real(sp), parameter :: relfac = two
! Local Scalars
logical(lk) :: ncnvrg, toofew
integer(${ik}$) :: ib, ibegin, idiscl, idiscu, ie, iend, iinfo, im, in, ioff, iorder, &
iout, irange, itmax, itmp1, iw, iwoff, j, jb, jdisc, je, nb, nwl, nwu
real(sp) :: atoli, bnorm, gl, gu, pivmin, rtoli, safemn, tmp1, tmp2, tnorm, ulp, wkill,&
wl, wlu, wu, wul
! Local Arrays
integer(${ik}$) :: idumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! decode range
if( stdlib_lsame( range, 'A' ) ) then
irange = 1_${ik}$
else if( stdlib_lsame( range, 'V' ) ) then
irange = 2_${ik}$
else if( stdlib_lsame( range, 'I' ) ) then
irange = 3_${ik}$
else
irange = 0_${ik}$
end if
! decode order
if( stdlib_lsame( order, 'B' ) ) then
iorder = 2_${ik}$
else if( stdlib_lsame( order, 'E' ) ) then
iorder = 1_${ik}$
else
iorder = 0_${ik}$
end if
! check for errors
if( irange<=0_${ik}$ ) then
info = -1_${ik}$
else if( iorder<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( irange==2_${ik}$ ) then
if( vl>=vu ) info = -5_${ik}$
else if( irange==3_${ik}$ .and. ( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) )then
info = -6_${ik}$
else if( irange==3_${ik}$ .and. ( iu<min( n, il ) .or. iu>n ) )then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEBZ', -info )
return
end if
! initialize error flags
info = 0_${ik}$
ncnvrg = .false.
toofew = .false.
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! simplifications:
if( irange==3_${ik}$ .and. il==1_${ik}$ .and. iu==n )irange = 1_${ik}$
! get machine constants
! nb is the minimum vector length for vector bisection, or 0
! if only scalar is to be done.
safemn = stdlib${ii}$_slamch( 'S' )
ulp = stdlib${ii}$_slamch( 'P' )
rtoli = ulp*relfac
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ )nb = 0_${ik}$
! special case when n=1
if( n==1_${ik}$ ) then
nsplit = 1_${ik}$
isplit( 1_${ik}$ ) = 1_${ik}$
if( irange==2_${ik}$ .and. ( vl>=d( 1_${ik}$ ) .or. vu<d( 1_${ik}$ ) ) ) then
m = 0_${ik}$
else
w( 1_${ik}$ ) = d( 1_${ik}$ )
iblock( 1_${ik}$ ) = 1_${ik}$
m = 1_${ik}$
end if
return
end if
! compute splitting points
nsplit = 1_${ik}$
work( n ) = zero
pivmin = one
do j = 2, n
tmp1 = e( j-1 )**2_${ik}$
if( abs( d( j )*d( j-1 ) )*ulp**2_${ik}$+safemn>tmp1 ) then
isplit( nsplit ) = j - 1_${ik}$
nsplit = nsplit + 1_${ik}$
work( j-1 ) = zero
else
work( j-1 ) = tmp1
pivmin = max( pivmin, tmp1 )
end if
end do
isplit( nsplit ) = n
pivmin = pivmin*safemn
! compute interval and atoli
if( irange==3_${ik}$ ) then
! range='i': compute the interval containing eigenvalues
! il through iu.
! compute gershgorin interval for entire (split) matrix
! and use it as the initial interval
gu = d( 1_${ik}$ )
gl = d( 1_${ik}$ )
tmp1 = zero
do j = 1, n - 1
tmp2 = sqrt( work( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( n )+tmp1 )
gl = min( gl, d( n )-tmp1 )
tnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin
gu = gu + fudge*tnorm*ulp*n + fudge*pivmin
! compute iteration parameters
itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
work( n+1 ) = gl
work( n+2 ) = gl
work( n+3 ) = gu
work( n+4 ) = gu
work( n+5 ) = gl
work( n+6 ) = gu
iwork( 1_${ik}$ ) = -1_${ik}$
iwork( 2_${ik}$ ) = -1_${ik}$
iwork( 3_${ik}$ ) = n + 1_${ik}$
iwork( 4_${ik}$ ) = n + 1_${ik}$
iwork( 5_${ik}$ ) = il - 1_${ik}$
iwork( 6_${ik}$ ) = iu
call stdlib${ii}$_slaebz( 3_${ik}$, itmax, n, 2_${ik}$, 2_${ik}$, nb, atoli, rtoli, pivmin, d, e,work, iwork( &
5_${ik}$ ), work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo )
if( iwork( 6_${ik}$ )==iu ) then
wl = work( n+1 )
wlu = work( n+3 )
nwl = iwork( 1_${ik}$ )
wu = work( n+4 )
wul = work( n+2 )
nwu = iwork( 4_${ik}$ )
else
wl = work( n+2 )
wlu = work( n+4 )
nwl = iwork( 2_${ik}$ )
wu = work( n+3 )
wul = work( n+1 )
nwu = iwork( 3_${ik}$ )
end if
if( nwl<0_${ik}$ .or. nwl>=n .or. nwu<1_${ik}$ .or. nwu>n ) then
info = 4_${ik}$
return
end if
else
! range='a' or 'v' -- set atoli
tnorm = max( abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) ),abs( d( n ) )+abs( e( n-1 ) ) )
do j = 2, n - 1
tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+abs( e( j ) ) )
end do
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
if( irange==2_${ik}$ ) then
wl = vl
wu = vu
else
wl = zero
wu = zero
end if
end if
! find eigenvalues -- loop over blocks and recompute nwl and nwu.
! nwl accumulates the number of eigenvalues .le. wl,
! nwu accumulates the number of eigenvalues .le. wu
m = 0_${ik}$
iend = 0_${ik}$
info = 0_${ik}$
nwl = 0_${ik}$
nwu = 0_${ik}$
loop_70: do jb = 1, nsplit
ioff = iend
ibegin = ioff + 1_${ik}$
iend = isplit( jb )
in = iend - ioff
if( in==1_${ik}$ ) then
! special case -- in=1
if( irange==1_${ik}$ .or. wl>=d( ibegin )-pivmin )nwl = nwl + 1_${ik}$
if( irange==1_${ik}$ .or. wu>=d( ibegin )-pivmin )nwu = nwu + 1_${ik}$
if( irange==1_${ik}$ .or. ( wl<d( ibegin )-pivmin .and. wu>=d( ibegin )-pivmin ) ) &
then
m = m + 1_${ik}$
w( m ) = d( ibegin )
iblock( m ) = jb
end if
else
! general case -- in > 1
! compute gershgorin interval
! and use it as the initial interval
gu = d( ibegin )
gl = d( ibegin )
tmp1 = zero
do j = ibegin, iend - 1
tmp2 = abs( e( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( iend )+tmp1 )
gl = min( gl, d( iend )-tmp1 )
bnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*bnorm*ulp*in - fudge*pivmin
gu = gu + fudge*bnorm*ulp*in + fudge*pivmin
! compute atoli for the current submatrix
if( abstol<=zero ) then
atoli = ulp*max( abs( gl ), abs( gu ) )
else
atoli = abstol
end if
if( irange>1_${ik}$ ) then
if( gu<wl ) then
nwl = nwl + in
nwu = nwu + in
cycle loop_70
end if
gl = max( gl, wl )
gu = min( gu, wu )
if( gl>=gu )cycle loop_70
end if
! set up initial interval
work( n+1 ) = gl
work( n+in+1 ) = gu
call stdlib${ii}$_slaebz( 1_${ik}$, 0_${ik}$, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e( &
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), im,iwork, w( m+1 &
), iblock( m+1 ), iinfo )
nwl = nwl + iwork( 1_${ik}$ )
nwu = nwu + iwork( in+1 )
iwoff = m - iwork( 1_${ik}$ )
! compute eigenvalues
itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + &
2_${ik}$
call stdlib${ii}$_slaebz( 2_${ik}$, itmax, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e(&
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), iout,iwork, w( &
m+1 ), iblock( m+1 ), iinfo )
! copy eigenvalues into w and iblock
! use -jb for block number for unconverged eigenvalues.
do j = 1, iout
tmp1 = half*( work( j+n )+work( j+in+n ) )
! flag non-convergence.
if( j>iout-iinfo ) then
ncnvrg = .true.
ib = -jb
else
ib = jb
end if
do je = iwork( j ) + 1 + iwoff,iwork( j+in ) + iwoff
w( je ) = tmp1
iblock( je ) = ib
end do
end do
m = m + im
end if
end do loop_70
! if range='i', then (wl,wu) contains eigenvalues nwl+1,...,nwu
! if nwl+1 < il or nwu > iu, discard extra eigenvalues.
if( irange==3_${ik}$ ) then
im = 0_${ik}$
idiscl = il - 1_${ik}$ - nwl
idiscu = nwu - iu
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
do je = 1, m
if( w( je )<=wlu .and. idiscl>0_${ik}$ ) then
idiscl = idiscl - 1_${ik}$
else if( w( je )>=wul .and. idiscu>0_${ik}$ ) then
idiscu = idiscu - 1_${ik}$
else
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
! code to deal with effects of bad arithmetic:
! some low eigenvalues to be discarded are not in (wl,wlu],
! or high eigenvalues to be discarded are not in (wul,wu]
! so just kill off the smallest idiscl/largest idiscu
! eigenvalues, by simply finding the smallest/largest
! eigenvalue(s).
! (if n(w) is monotone non-decreasing, this should never
! happen.)
if( idiscl>0_${ik}$ ) then
wkill = wu
do jdisc = 1, idiscl
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )<wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
if( idiscu>0_${ik}$ ) then
wkill = wl
do jdisc = 1, idiscu
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )>wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
im = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ ) then
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl<0_${ik}$ .or. idiscu<0_${ik}$ ) then
toofew = .true.
end if
end if
! if order='b', do nothing -- the eigenvalues are already sorted
! by block.
! if order='e', sort the eigenvalues from smallest to largest
if( iorder==1_${ik}$ .and. nsplit>1_${ik}$ ) then
do je = 1, m - 1
ie = 0_${ik}$
tmp1 = w( je )
do j = je + 1, m
if( w( j )<tmp1 ) then
ie = j
tmp1 = w( j )
end if
end do
if( ie/=0_${ik}$ ) then
itmp1 = iblock( ie )
w( ie ) = w( je )
iblock( ie ) = iblock( je )
w( je ) = tmp1
iblock( je ) = itmp1
end if
end do
end if
info = 0_${ik}$
if( ncnvrg )info = info + 1_${ik}$
if( toofew )info = info + 2_${ik}$
return
end subroutine stdlib${ii}$_sstebz
pure module subroutine stdlib${ii}$_dstebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w, &
!! DSTEBZ computes the eigenvalues of a symmetric tridiagonal
!! matrix T. The user may ask for all eigenvalues, all eigenvalues
!! in the half-open interval (VL, VU], or the IL-th through IU-th
!! eigenvalues.
!! To avoid overflow, the matrix must be scaled so that its
!! largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!! accuracy, it should not be much smaller than that.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966.
iblock, isplit, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: order, range
integer(${ik}$), intent(in) :: il, iu, n
integer(${ik}$), intent(out) :: info, m, nsplit
real(dp), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: iblock(*), isplit(*), iwork(*)
real(dp), intent(in) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
real(dp), parameter :: fudge = 2.1_dp
real(dp), parameter :: relfac = two
! Local Scalars
logical(lk) :: ncnvrg, toofew
integer(${ik}$) :: ib, ibegin, idiscl, idiscu, ie, iend, iinfo, im, in, ioff, iorder, &
iout, irange, itmax, itmp1, iw, iwoff, j, jb, jdisc, je, nb, nwl, nwu
real(dp) :: atoli, bnorm, gl, gu, pivmin, rtoli, safemn, tmp1, tmp2, tnorm, ulp, wkill,&
wl, wlu, wu, wul
! Local Arrays
integer(${ik}$) :: idumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! decode range
if( stdlib_lsame( range, 'A' ) ) then
irange = 1_${ik}$
else if( stdlib_lsame( range, 'V' ) ) then
irange = 2_${ik}$
else if( stdlib_lsame( range, 'I' ) ) then
irange = 3_${ik}$
else
irange = 0_${ik}$
end if
! decode order
if( stdlib_lsame( order, 'B' ) ) then
iorder = 2_${ik}$
else if( stdlib_lsame( order, 'E' ) ) then
iorder = 1_${ik}$
else
iorder = 0_${ik}$
end if
! check for errors
if( irange<=0_${ik}$ ) then
info = -1_${ik}$
else if( iorder<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( irange==2_${ik}$ ) then
if( vl>=vu )info = -5_${ik}$
else if( irange==3_${ik}$ .and. ( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) )then
info = -6_${ik}$
else if( irange==3_${ik}$ .and. ( iu<min( n, il ) .or. iu>n ) )then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEBZ', -info )
return
end if
! initialize error flags
info = 0_${ik}$
ncnvrg = .false.
toofew = .false.
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! simplifications:
if( irange==3_${ik}$ .and. il==1_${ik}$ .and. iu==n )irange = 1_${ik}$
! get machine constants
! nb is the minimum vector length for vector bisection, or 0
! if only scalar is to be done.
safemn = stdlib${ii}$_dlamch( 'S' )
ulp = stdlib${ii}$_dlamch( 'P' )
rtoli = ulp*relfac
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ )nb = 0_${ik}$
! special case when n=1
if( n==1_${ik}$ ) then
nsplit = 1_${ik}$
isplit( 1_${ik}$ ) = 1_${ik}$
if( irange==2_${ik}$ .and. ( vl>=d( 1_${ik}$ ) .or. vu<d( 1_${ik}$ ) ) ) then
m = 0_${ik}$
else
w( 1_${ik}$ ) = d( 1_${ik}$ )
iblock( 1_${ik}$ ) = 1_${ik}$
m = 1_${ik}$
end if
return
end if
! compute splitting points
nsplit = 1_${ik}$
work( n ) = zero
pivmin = one
do j = 2, n
tmp1 = e( j-1 )**2_${ik}$
if( abs( d( j )*d( j-1 ) )*ulp**2_${ik}$+safemn>tmp1 ) then
isplit( nsplit ) = j - 1_${ik}$
nsplit = nsplit + 1_${ik}$
work( j-1 ) = zero
else
work( j-1 ) = tmp1
pivmin = max( pivmin, tmp1 )
end if
end do
isplit( nsplit ) = n
pivmin = pivmin*safemn
! compute interval and atoli
if( irange==3_${ik}$ ) then
! range='i': compute the interval containing eigenvalues
! il through iu.
! compute gershgorin interval for entire (split) matrix
! and use it as the initial interval
gu = d( 1_${ik}$ )
gl = d( 1_${ik}$ )
tmp1 = zero
do j = 1, n - 1
tmp2 = sqrt( work( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( n )+tmp1 )
gl = min( gl, d( n )-tmp1 )
tnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin
gu = gu + fudge*tnorm*ulp*n + fudge*pivmin
! compute iteration parameters
itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
work( n+1 ) = gl
work( n+2 ) = gl
work( n+3 ) = gu
work( n+4 ) = gu
work( n+5 ) = gl
work( n+6 ) = gu
iwork( 1_${ik}$ ) = -1_${ik}$
iwork( 2_${ik}$ ) = -1_${ik}$
iwork( 3_${ik}$ ) = n + 1_${ik}$
iwork( 4_${ik}$ ) = n + 1_${ik}$
iwork( 5_${ik}$ ) = il - 1_${ik}$
iwork( 6_${ik}$ ) = iu
call stdlib${ii}$_dlaebz( 3_${ik}$, itmax, n, 2_${ik}$, 2_${ik}$, nb, atoli, rtoli, pivmin, d, e,work, iwork( &
5_${ik}$ ), work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo )
if( iwork( 6_${ik}$ )==iu ) then
wl = work( n+1 )
wlu = work( n+3 )
nwl = iwork( 1_${ik}$ )
wu = work( n+4 )
wul = work( n+2 )
nwu = iwork( 4_${ik}$ )
else
wl = work( n+2 )
wlu = work( n+4 )
nwl = iwork( 2_${ik}$ )
wu = work( n+3 )
wul = work( n+1 )
nwu = iwork( 3_${ik}$ )
end if
if( nwl<0_${ik}$ .or. nwl>=n .or. nwu<1_${ik}$ .or. nwu>n ) then
info = 4_${ik}$
return
end if
else
! range='a' or 'v' -- set atoli
tnorm = max( abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) ),abs( d( n ) )+abs( e( n-1 ) ) )
do j = 2, n - 1
tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+abs( e( j ) ) )
end do
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
if( irange==2_${ik}$ ) then
wl = vl
wu = vu
else
wl = zero
wu = zero
end if
end if
! find eigenvalues -- loop over blocks and recompute nwl and nwu.
! nwl accumulates the number of eigenvalues .le. wl,
! nwu accumulates the number of eigenvalues .le. wu
m = 0_${ik}$
iend = 0_${ik}$
info = 0_${ik}$
nwl = 0_${ik}$
nwu = 0_${ik}$
loop_70: do jb = 1, nsplit
ioff = iend
ibegin = ioff + 1_${ik}$
iend = isplit( jb )
in = iend - ioff
if( in==1_${ik}$ ) then
! special case -- in=1
if( irange==1_${ik}$ .or. wl>=d( ibegin )-pivmin )nwl = nwl + 1_${ik}$
if( irange==1_${ik}$ .or. wu>=d( ibegin )-pivmin )nwu = nwu + 1_${ik}$
if( irange==1_${ik}$ .or. ( wl<d( ibegin )-pivmin .and. wu>=d( ibegin )-pivmin ) ) &
then
m = m + 1_${ik}$
w( m ) = d( ibegin )
iblock( m ) = jb
end if
else
! general case -- in > 1
! compute gershgorin interval
! and use it as the initial interval
gu = d( ibegin )
gl = d( ibegin )
tmp1 = zero
do j = ibegin, iend - 1
tmp2 = abs( e( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( iend )+tmp1 )
gl = min( gl, d( iend )-tmp1 )
bnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*bnorm*ulp*in - fudge*pivmin
gu = gu + fudge*bnorm*ulp*in + fudge*pivmin
! compute atoli for the current submatrix
if( abstol<=zero ) then
atoli = ulp*max( abs( gl ), abs( gu ) )
else
atoli = abstol
end if
if( irange>1_${ik}$ ) then
if( gu<wl ) then
nwl = nwl + in
nwu = nwu + in
cycle loop_70
end if
gl = max( gl, wl )
gu = min( gu, wu )
if( gl>=gu )cycle loop_70
end if
! set up initial interval
work( n+1 ) = gl
work( n+in+1 ) = gu
call stdlib${ii}$_dlaebz( 1_${ik}$, 0_${ik}$, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e( &
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), im,iwork, w( m+1 &
), iblock( m+1 ), iinfo )
nwl = nwl + iwork( 1_${ik}$ )
nwu = nwu + iwork( in+1 )
iwoff = m - iwork( 1_${ik}$ )
! compute eigenvalues
itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + &
2_${ik}$
call stdlib${ii}$_dlaebz( 2_${ik}$, itmax, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e(&
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), iout,iwork, w( &
m+1 ), iblock( m+1 ), iinfo )
! copy eigenvalues into w and iblock
! use -jb for block number for unconverged eigenvalues.
do j = 1, iout
tmp1 = half*( work( j+n )+work( j+in+n ) )
! flag non-convergence.
if( j>iout-iinfo ) then
ncnvrg = .true.
ib = -jb
else
ib = jb
end if
do je = iwork( j ) + 1 + iwoff,iwork( j+in ) + iwoff
w( je ) = tmp1
iblock( je ) = ib
end do
end do
m = m + im
end if
end do loop_70
! if range='i', then (wl,wu) contains eigenvalues nwl+1,...,nwu
! if nwl+1 < il or nwu > iu, discard extra eigenvalues.
if( irange==3_${ik}$ ) then
im = 0_${ik}$
idiscl = il - 1_${ik}$ - nwl
idiscu = nwu - iu
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
do je = 1, m
if( w( je )<=wlu .and. idiscl>0_${ik}$ ) then
idiscl = idiscl - 1_${ik}$
else if( w( je )>=wul .and. idiscu>0_${ik}$ ) then
idiscu = idiscu - 1_${ik}$
else
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
! code to deal with effects of bad arithmetic:
! some low eigenvalues to be discarded are not in (wl,wlu],
! or high eigenvalues to be discarded are not in (wul,wu]
! so just kill off the smallest idiscl/largest idiscu
! eigenvalues, by simply finding the smallest/largest
! eigenvalue(s).
! (if n(w) is monotone non-decreasing, this should never
! happen.)
if( idiscl>0_${ik}$ ) then
wkill = wu
do jdisc = 1, idiscl
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )<wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
if( idiscu>0_${ik}$ ) then
wkill = wl
do jdisc = 1, idiscu
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )>wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
im = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ ) then
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl<0_${ik}$ .or. idiscu<0_${ik}$ ) then
toofew = .true.
end if
end if
! if order='b', do nothing -- the eigenvalues are already sorted
! by block.
! if order='e', sort the eigenvalues from smallest to largest
if( iorder==1_${ik}$ .and. nsplit>1_${ik}$ ) then
do je = 1, m - 1
ie = 0_${ik}$
tmp1 = w( je )
do j = je + 1, m
if( w( j )<tmp1 ) then
ie = j
tmp1 = w( j )
end if
end do
if( ie/=0_${ik}$ ) then
itmp1 = iblock( ie )
w( ie ) = w( je )
iblock( ie ) = iblock( je )
w( je ) = tmp1
iblock( je ) = itmp1
end if
end do
end if
info = 0_${ik}$
if( ncnvrg )info = info + 1_${ik}$
if( toofew )info = info + 2_${ik}$
return
end subroutine stdlib${ii}$_dstebz
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w, &
!! DSTEBZ: computes the eigenvalues of a symmetric tridiagonal
!! matrix T. The user may ask for all eigenvalues, all eigenvalues
!! in the half-open interval (VL, VU], or the IL-th through IU-th
!! eigenvalues.
!! To avoid overflow, the matrix must be scaled so that its
!! largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!! accuracy, it should not be much smaller than that.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966.
iblock, isplit, work, iwork,info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: order, range
integer(${ik}$), intent(in) :: il, iu, n
integer(${ik}$), intent(out) :: info, m, nsplit
real(${rk}$), intent(in) :: abstol, vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: iblock(*), isplit(*), iwork(*)
real(${rk}$), intent(in) :: d(*), e(*)
real(${rk}$), intent(out) :: w(*), work(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: fudge = 2.1_${rk}$
real(${rk}$), parameter :: relfac = two
! Local Scalars
logical(lk) :: ncnvrg, toofew
integer(${ik}$) :: ib, ibegin, idiscl, idiscu, ie, iend, iinfo, im, in, ioff, iorder, &
iout, irange, itmax, itmp1, iw, iwoff, j, jb, jdisc, je, nb, nwl, nwu
real(${rk}$) :: atoli, bnorm, gl, gu, pivmin, rtoli, safemn, tmp1, tmp2, tnorm, ulp, wkill,&
wl, wlu, wu, wul
! Local Arrays
integer(${ik}$) :: idumma(1_${ik}$)
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
! decode range
if( stdlib_lsame( range, 'A' ) ) then
irange = 1_${ik}$
else if( stdlib_lsame( range, 'V' ) ) then
irange = 2_${ik}$
else if( stdlib_lsame( range, 'I' ) ) then
irange = 3_${ik}$
else
irange = 0_${ik}$
end if
! decode order
if( stdlib_lsame( order, 'B' ) ) then
iorder = 2_${ik}$
else if( stdlib_lsame( order, 'E' ) ) then
iorder = 1_${ik}$
else
iorder = 0_${ik}$
end if
! check for errors
if( irange<=0_${ik}$ ) then
info = -1_${ik}$
else if( iorder<=0_${ik}$ ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( irange==2_${ik}$ ) then
if( vl>=vu )info = -5_${ik}$
else if( irange==3_${ik}$ .and. ( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) )then
info = -6_${ik}$
else if( irange==3_${ik}$ .and. ( iu<min( n, il ) .or. iu>n ) )then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEBZ', -info )
return
end if
! initialize error flags
info = 0_${ik}$
ncnvrg = .false.
toofew = .false.
! quick return if possible
m = 0_${ik}$
if( n==0 )return
! simplifications:
if( irange==3_${ik}$ .and. il==1_${ik}$ .and. iu==n )irange = 1_${ik}$
! get machine constants
! nb is the minimum vector length for vector bisection, or 0
! if only scalar is to be done.
safemn = stdlib${ii}$_${ri}$lamch( 'S' )
ulp = stdlib${ii}$_${ri}$lamch( 'P' )
rtoli = ulp*relfac
nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ )
if( nb<=1_${ik}$ )nb = 0_${ik}$
! special case when n=1
if( n==1_${ik}$ ) then
nsplit = 1_${ik}$
isplit( 1_${ik}$ ) = 1_${ik}$
if( irange==2_${ik}$ .and. ( vl>=d( 1_${ik}$ ) .or. vu<d( 1_${ik}$ ) ) ) then
m = 0_${ik}$
else
w( 1_${ik}$ ) = d( 1_${ik}$ )
iblock( 1_${ik}$ ) = 1_${ik}$
m = 1_${ik}$
end if
return
end if
! compute splitting points
nsplit = 1_${ik}$
work( n ) = zero
pivmin = one
do j = 2, n
tmp1 = e( j-1 )**2_${ik}$
if( abs( d( j )*d( j-1 ) )*ulp**2_${ik}$+safemn>tmp1 ) then
isplit( nsplit ) = j - 1_${ik}$
nsplit = nsplit + 1_${ik}$
work( j-1 ) = zero
else
work( j-1 ) = tmp1
pivmin = max( pivmin, tmp1 )
end if
end do
isplit( nsplit ) = n
pivmin = pivmin*safemn
! compute interval and atoli
if( irange==3_${ik}$ ) then
! range='i': compute the interval containing eigenvalues
! il through iu.
! compute gershgorin interval for entire (split) matrix
! and use it as the initial interval
gu = d( 1_${ik}$ )
gl = d( 1_${ik}$ )
tmp1 = zero
do j = 1, n - 1
tmp2 = sqrt( work( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( n )+tmp1 )
gl = min( gl, d( n )-tmp1 )
tnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin
gu = gu + fudge*tnorm*ulp*n + fudge*pivmin
! compute iteration parameters
itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
work( n+1 ) = gl
work( n+2 ) = gl
work( n+3 ) = gu
work( n+4 ) = gu
work( n+5 ) = gl
work( n+6 ) = gu
iwork( 1_${ik}$ ) = -1_${ik}$
iwork( 2_${ik}$ ) = -1_${ik}$
iwork( 3_${ik}$ ) = n + 1_${ik}$
iwork( 4_${ik}$ ) = n + 1_${ik}$
iwork( 5_${ik}$ ) = il - 1_${ik}$
iwork( 6_${ik}$ ) = iu
call stdlib${ii}$_${ri}$laebz( 3_${ik}$, itmax, n, 2_${ik}$, 2_${ik}$, nb, atoli, rtoli, pivmin, d, e,work, iwork( &
5_${ik}$ ), work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo )
if( iwork( 6_${ik}$ )==iu ) then
wl = work( n+1 )
wlu = work( n+3 )
nwl = iwork( 1_${ik}$ )
wu = work( n+4 )
wul = work( n+2 )
nwu = iwork( 4_${ik}$ )
else
wl = work( n+2 )
wlu = work( n+4 )
nwl = iwork( 2_${ik}$ )
wu = work( n+3 )
wul = work( n+1 )
nwu = iwork( 3_${ik}$ )
end if
if( nwl<0_${ik}$ .or. nwl>=n .or. nwu<1_${ik}$ .or. nwu>n ) then
info = 4_${ik}$
return
end if
else
! range='a' or 'v' -- set atoli
tnorm = max( abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) ),abs( d( n ) )+abs( e( n-1 ) ) )
do j = 2, n - 1
tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+abs( e( j ) ) )
end do
if( abstol<=zero ) then
atoli = ulp*tnorm
else
atoli = abstol
end if
if( irange==2_${ik}$ ) then
wl = vl
wu = vu
else
wl = zero
wu = zero
end if
end if
! find eigenvalues -- loop over blocks and recompute nwl and nwu.
! nwl accumulates the number of eigenvalues .le. wl,
! nwu accumulates the number of eigenvalues .le. wu
m = 0_${ik}$
iend = 0_${ik}$
info = 0_${ik}$
nwl = 0_${ik}$
nwu = 0_${ik}$
loop_70: do jb = 1, nsplit
ioff = iend
ibegin = ioff + 1_${ik}$
iend = isplit( jb )
in = iend - ioff
if( in==1_${ik}$ ) then
! special case -- in=1
if( irange==1_${ik}$ .or. wl>=d( ibegin )-pivmin )nwl = nwl + 1_${ik}$
if( irange==1_${ik}$ .or. wu>=d( ibegin )-pivmin )nwu = nwu + 1_${ik}$
if( irange==1_${ik}$ .or. ( wl<d( ibegin )-pivmin .and. wu>=d( ibegin )-pivmin ) ) &
then
m = m + 1_${ik}$
w( m ) = d( ibegin )
iblock( m ) = jb
end if
else
! general case -- in > 1
! compute gershgorin interval
! and use it as the initial interval
gu = d( ibegin )
gl = d( ibegin )
tmp1 = zero
do j = ibegin, iend - 1
tmp2 = abs( e( j ) )
gu = max( gu, d( j )+tmp1+tmp2 )
gl = min( gl, d( j )-tmp1-tmp2 )
tmp1 = tmp2
end do
gu = max( gu, d( iend )+tmp1 )
gl = min( gl, d( iend )-tmp1 )
bnorm = max( abs( gl ), abs( gu ) )
gl = gl - fudge*bnorm*ulp*in - fudge*pivmin
gu = gu + fudge*bnorm*ulp*in + fudge*pivmin
! compute atoli for the current submatrix
if( abstol<=zero ) then
atoli = ulp*max( abs( gl ), abs( gu ) )
else
atoli = abstol
end if
if( irange>1_${ik}$ ) then
if( gu<wl ) then
nwl = nwl + in
nwu = nwu + in
cycle loop_70
end if
gl = max( gl, wl )
gu = min( gu, wu )
if( gl>=gu )cycle loop_70
end if
! set up initial interval
work( n+1 ) = gl
work( n+in+1 ) = gu
call stdlib${ii}$_${ri}$laebz( 1_${ik}$, 0_${ik}$, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e( &
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), im,iwork, w( m+1 &
), iblock( m+1 ), iinfo )
nwl = nwl + iwork( 1_${ik}$ )
nwu = nwu + iwork( in+1 )
iwoff = m - iwork( 1_${ik}$ )
! compute eigenvalues
itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + &
2_${ik}$
call stdlib${ii}$_${ri}$laebz( 2_${ik}$, itmax, in, in, 1_${ik}$, nb, atoli, rtoli, pivmin,d( ibegin ), e(&
ibegin ), work( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), iout,iwork, w( &
m+1 ), iblock( m+1 ), iinfo )
! copy eigenvalues into w and iblock
! use -jb for block number for unconverged eigenvalues.
do j = 1, iout
tmp1 = half*( work( j+n )+work( j+in+n ) )
! flag non-convergence.
if( j>iout-iinfo ) then
ncnvrg = .true.
ib = -jb
else
ib = jb
end if
do je = iwork( j ) + 1 + iwoff,iwork( j+in ) + iwoff
w( je ) = tmp1
iblock( je ) = ib
end do
end do
m = m + im
end if
end do loop_70
! if range='i', then (wl,wu) contains eigenvalues nwl+1,...,nwu
! if nwl+1 < il or nwu > iu, discard extra eigenvalues.
if( irange==3_${ik}$ ) then
im = 0_${ik}$
idiscl = il - 1_${ik}$ - nwl
idiscu = nwu - iu
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
do je = 1, m
if( w( je )<=wlu .and. idiscl>0_${ik}$ ) then
idiscl = idiscl - 1_${ik}$
else if( w( je )>=wul .and. idiscu>0_${ik}$ ) then
idiscu = idiscu - 1_${ik}$
else
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then
! code to deal with effects of bad arithmetic:
! some low eigenvalues to be discarded are not in (wl,wlu],
! or high eigenvalues to be discarded are not in (wul,wu]
! so just kill off the smallest idiscl/largest idiscu
! eigenvalues, by simply finding the smallest/largest
! eigenvalue(s).
! (if n(w) is monotone non-decreasing, this should never
! happen.)
if( idiscl>0_${ik}$ ) then
wkill = wu
do jdisc = 1, idiscl
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )<wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
if( idiscu>0_${ik}$ ) then
wkill = wl
do jdisc = 1, idiscu
iw = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ .and.( w( je )>wkill .or. iw==0_${ik}$ ) ) then
iw = je
wkill = w( je )
end if
end do
iblock( iw ) = 0_${ik}$
end do
end if
im = 0_${ik}$
do je = 1, m
if( iblock( je )/=0_${ik}$ ) then
im = im + 1_${ik}$
w( im ) = w( je )
iblock( im ) = iblock( je )
end if
end do
m = im
end if
if( idiscl<0_${ik}$ .or. idiscu<0_${ik}$ ) then
toofew = .true.
end if
end if
! if order='b', do nothing -- the eigenvalues are already sorted
! by block.
! if order='e', sort the eigenvalues from smallest to largest
if( iorder==1_${ik}$ .and. nsplit>1_${ik}$ ) then
do je = 1, m - 1
ie = 0_${ik}$
tmp1 = w( je )
do j = je + 1, m
if( w( j )<tmp1 ) then
ie = j
tmp1 = w( j )
end if
end do
if( ie/=0_${ik}$ ) then
itmp1 = iblock( ie )
w( ie ) = w( je )
iblock( ie ) = iblock( je )
w( je ) = tmp1
iblock( je ) = itmp1
end if
end do
end if
info = 0_${ik}$
if( ncnvrg )info = info + 1_${ik}$
if( toofew )info = info + 2_${ik}$
return
end subroutine stdlib${ii}$_${ri}$stebz
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssterf( n, d, e, info )
!! SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
!! using the Pal-Walker-Kahan variant of the QL or QR algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, iscale, jtot, l, l1, lend, lendsv, lsv, m, nmaxit
real(sp) :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, oldgam, p, r, rt1, rt2, rte, &
s, safmax, safmin, sigma, ssfmax, ssfmin
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! quick return if possible
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'SSTERF', -info )
return
end if
if( n<=1 )return
! determine the unit roundoff for this environment.
eps = stdlib${ii}$_slamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues of the tridiagonal matrix.
nmaxit = n*maxit
sigma = zero
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
10 continue
if( l1>n )go to 170
if( l1>1_${ik}$ )e( l1-1 ) = zero
do m = l1, n - 1
if( abs( e( m ) )<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) &
then
e( m ) = zero
go to 30
end if
end do
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_slanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
do i = l, lend - 1
e( i ) = e( i )**2_${ik}$
end do
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>=l ) then
! ql iteration
! look for small subdiagonal element.
50 continue
if( l/=lend ) then
do m = l, lend - 1
if( abs( e( m ) )<=eps2*abs( d( m )*d( m+1 ) ) )go to 70
end do
end if
m = lend
70 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 90
! if remaining matrix is 2 by 2, use stdlib_slae2 to compute its
! eigenvalues.
if( m==l+1 ) then
rte = sqrt( e( l ) )
call stdlib${ii}$_slae2( d( l ), rte, d( l+1 ), rt1, rt2 )
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 50
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l ) )
sigma = ( d( l+1 )-p ) / ( two*rte )
r = stdlib${ii}$_slapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m - 1, l, -1
bb = e( i )
r = p + bb
if( i/=m-1 )e( i+1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i )
gamma = c*( alpha-sigma ) - s*oldgam
d( i+1 ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l ) = s*p
d( l ) = sigma + gamma
go to 50
! eigenvalue found.
90 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 50
go to 150
else
! qr iteration
! look for small superdiagonal element.
100 continue
do m = l, lend + 1, -1
if( abs( e( m-1 ) )<=eps2*abs( d( m )*d( m-1 ) ) )go to 120
end do
m = lend
120 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 140
! if remaining matrix is 2 by 2, use stdlib_slae2 to compute its
! eigenvalues.
if( m==l-1 ) then
rte = sqrt( e( l-1 ) )
call stdlib${ii}$_slae2( d( l ), rte, d( l-1 ), rt1, rt2 )
d( l ) = rt1
d( l-1 ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 100
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l-1 ) )
sigma = ( d( l-1 )-p ) / ( two*rte )
r = stdlib${ii}$_slapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m, l - 1
bb = e( i )
r = p + bb
if( i/=m )e( i-1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i+1 )
gamma = c*( alpha-sigma ) - s*oldgam
d( i ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l-1 ) = s*p
d( l ) = sigma + gamma
go to 100
! eigenvalue found.
140 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 100
go to 150
end if
! undo scaling if necessary
150 continue
if( iscale==1_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
if( iscale==2_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 180
! sort eigenvalues in increasing order.
170 continue
call stdlib${ii}$_slasrt( 'I', n, d, info )
180 continue
return
end subroutine stdlib${ii}$_ssterf
pure module subroutine stdlib${ii}$_dsterf( n, d, e, info )
!! DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
!! using the Pal-Walker-Kahan variant of the QL or QR algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, iscale, jtot, l, l1, lend, lendsv, lsv, m, nmaxit
real(dp) :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, oldgam, p, r, rt1, rt2, rte, &
s, safmax, safmin, sigma, ssfmax, ssfmin, rmax
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! quick return if possible
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DSTERF', -info )
return
end if
if( n<=1 )return
! determine the unit roundoff for this environment.
eps = stdlib${ii}$_dlamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
rmax = stdlib${ii}$_dlamch( 'O' )
! compute the eigenvalues of the tridiagonal matrix.
nmaxit = n*maxit
sigma = zero
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
10 continue
if( l1>n )go to 170
if( l1>1_${ik}$ )e( l1-1 ) = zero
do m = l1, n - 1
if( abs( e( m ) )<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) &
then
e( m ) = zero
go to 30
end if
end do
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_dlanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( (anorm>ssfmax) ) then
iscale = 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
do i = l, lend - 1
e( i ) = e( i )**2_${ik}$
end do
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>=l ) then
! ql iteration
! look for small subdiagonal element.
50 continue
if( l/=lend ) then
do m = l, lend - 1
if( abs( e( m ) )<=eps2*abs( d( m )*d( m+1 ) ) )go to 70
end do
end if
m = lend
70 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 90
! if remaining matrix is 2 by 2, use stdlib_dlae2 to compute its
! eigenvalues.
if( m==l+1 ) then
rte = sqrt( e( l ) )
call stdlib${ii}$_dlae2( d( l ), rte, d( l+1 ), rt1, rt2 )
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 50
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l ) )
sigma = ( d( l+1 )-p ) / ( two*rte )
r = stdlib${ii}$_dlapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m - 1, l, -1
bb = e( i )
r = p + bb
if( i/=m-1 )e( i+1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i )
gamma = c*( alpha-sigma ) - s*oldgam
d( i+1 ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l ) = s*p
d( l ) = sigma + gamma
go to 50
! eigenvalue found.
90 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 50
go to 150
else
! qr iteration
! look for small superdiagonal element.
100 continue
do m = l, lend + 1, -1
if( abs( e( m-1 ) )<=eps2*abs( d( m )*d( m-1 ) ) )go to 120
end do
m = lend
120 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 140
! if remaining matrix is 2 by 2, use stdlib_dlae2 to compute its
! eigenvalues.
if( m==l-1 ) then
rte = sqrt( e( l-1 ) )
call stdlib${ii}$_dlae2( d( l ), rte, d( l-1 ), rt1, rt2 )
d( l ) = rt1
d( l-1 ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 100
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l-1 ) )
sigma = ( d( l-1 )-p ) / ( two*rte )
r = stdlib${ii}$_dlapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m, l - 1
bb = e( i )
r = p + bb
if( i/=m )e( i-1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i+1 )
gamma = c*( alpha-sigma ) - s*oldgam
d( i ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l-1 ) = s*p
d( l ) = sigma + gamma
go to 100
! eigenvalue found.
140 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 100
go to 150
end if
! undo scaling if necessary
150 continue
if( iscale==1_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
if( iscale==2_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 180
! sort eigenvalues in increasing order.
170 continue
call stdlib${ii}$_dlasrt( 'I', n, d, info )
180 continue
return
end subroutine stdlib${ii}$_dsterf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$sterf( n, d, e, info )
!! DSTERF: computes all eigenvalues of a symmetric tridiagonal matrix
!! using the Pal-Walker-Kahan variant of the QL or QR algorithm.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: n
! Array Arguments
real(${rk}$), intent(inout) :: d(*), e(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, iscale, jtot, l, l1, lend, lendsv, lsv, m, nmaxit
real(${rk}$) :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, oldgam, p, r, rt1, rt2, rte, &
s, safmax, safmin, sigma, ssfmax, ssfmin, rmax
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! quick return if possible
if( n<0_${ik}$ ) then
info = -1_${ik}$
call stdlib${ii}$_xerbla( 'DSTERF', -info )
return
end if
if( n<=1 )return
! determine the unit roundoff for this environment.
eps = stdlib${ii}$_${ri}$lamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
rmax = stdlib${ii}$_${ri}$lamch( 'O' )
! compute the eigenvalues of the tridiagonal matrix.
nmaxit = n*maxit
sigma = zero
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
10 continue
if( l1>n )go to 170
if( l1>1_${ik}$ )e( l1-1 ) = zero
do m = l1, n - 1
if( abs( e( m ) )<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) &
then
e( m ) = zero
go to 30
end if
end do
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_${ri}$lanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( (anorm>ssfmax) ) then
iscale = 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
do i = l, lend - 1
e( i ) = e( i )**2_${ik}$
end do
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>=l ) then
! ql iteration
! look for small subdiagonal element.
50 continue
if( l/=lend ) then
do m = l, lend - 1
if( abs( e( m ) )<=eps2*abs( d( m )*d( m+1 ) ) )go to 70
end do
end if
m = lend
70 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 90
! if remaining matrix is 2 by 2, use stdlib_${ri}$lae2 to compute its
! eigenvalues.
if( m==l+1 ) then
rte = sqrt( e( l ) )
call stdlib${ii}$_${ri}$lae2( d( l ), rte, d( l+1 ), rt1, rt2 )
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 50
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l ) )
sigma = ( d( l+1 )-p ) / ( two*rte )
r = stdlib${ii}$_${ri}$lapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m - 1, l, -1
bb = e( i )
r = p + bb
if( i/=m-1 )e( i+1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i )
gamma = c*( alpha-sigma ) - s*oldgam
d( i+1 ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l ) = s*p
d( l ) = sigma + gamma
go to 50
! eigenvalue found.
90 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 50
go to 150
else
! qr iteration
! look for small superdiagonal element.
100 continue
do m = l, lend + 1, -1
if( abs( e( m-1 ) )<=eps2*abs( d( m )*d( m-1 ) ) )go to 120
end do
m = lend
120 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 140
! if remaining matrix is 2 by 2, use stdlib_${ri}$lae2 to compute its
! eigenvalues.
if( m==l-1 ) then
rte = sqrt( e( l-1 ) )
call stdlib${ii}$_${ri}$lae2( d( l ), rte, d( l-1 ), rt1, rt2 )
d( l ) = rt1
d( l-1 ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 100
go to 150
end if
if( jtot==nmaxit )go to 150
jtot = jtot + 1_${ik}$
! form shift.
rte = sqrt( e( l-1 ) )
sigma = ( d( l-1 )-p ) / ( two*rte )
r = stdlib${ii}$_${ri}$lapy2( sigma, one )
sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
c = one
s = zero
gamma = d( m ) - sigma
p = gamma*gamma
! inner loop
do i = m, l - 1
bb = e( i )
r = p + bb
if( i/=m )e( i-1 ) = s*r
oldc = c
c = p / r
s = bb / r
oldgam = gamma
alpha = d( i+1 )
gamma = c*( alpha-sigma ) - s*oldgam
d( i ) = oldgam + ( alpha-gamma )
if( c/=zero ) then
p = ( gamma*gamma ) / c
else
p = oldc*bb
end if
end do
e( l-1 ) = s*p
d( l ) = sigma + gamma
go to 100
! eigenvalue found.
140 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 100
go to 150
end if
! undo scaling if necessary
150 continue
if( iscale==1_${ik}$ )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
if( iscale==2_${ik}$ )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), &
n, info )
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 180
! sort eigenvalues in increasing order.
170 continue
call stdlib${ii}$_${ri}$lasrt( 'I', n, d, info )
180 continue
return
end subroutine stdlib${ii}$_${ri}$sterf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band real symmetric matrix can also be
!! found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See SLAED3 for details.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), e(*), z(ldz,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, &
storez, strtrw
real(sp) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'SSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( n<=smlsiz ) then
liwmin = 1_${ik}$
lwmin = 2_${ik}$*( n - 1_${ik}$ )
else
lgn = int( log( real( n,KIND=sp) )/log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( icompz==1_${ik}$ ) then
lwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'SSTEDC', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_ssterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_ssterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_ssterf( n, d, e, info )
go to 50
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_ssteqr( compz, n, d, e, z, ldz, work, info )
else
! if compz = 'v', the z matrix must be stored elsewhere for later
! use.
if( icompz==1_${ik}$ ) then
storez = 1_${ik}$ + n*n
else
storez = 1_${ik}$
end if
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, z, ldz )
end if
! scale.
orgnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( orgnrm==zero )go to 50
eps = stdlib${ii}$_slamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
10 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
20 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 20
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m==1_${ik}$ ) then
start = finish + 1_${ik}$
go to 10
end if
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_slanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
if( icompz==1_${ik}$ ) then
strtrw = 1_${ik}$
else
strtrw = start
end if
call stdlib${ii}$_slaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), &
ldz, work( 1_${ik}$ ), n,work( storez ), iwork, info )
if( info/=0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 50
end if
! scale back.
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
if( icompz==1_${ik}$ ) then
! since qr won't update a z matrix which is larger than
! the length of d, we must solve the sub-problem in a
! workspace and then multiply back into z.
call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), &
info )
call stdlib${ii}$_slacpy( 'A', n, m, z( 1_${ik}$, start ), ldz,work( storez ), n )
call stdlib${ii}$_sgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,&
z( 1_${ik}$, start ), ldz )
else if( icompz==2_${ik}$ ) then
call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, &
work, info )
else
call stdlib${ii}$_ssterf( m, d( start ), e( start ), info )
end if
if( info/=0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 50
end if
end if
start = finish + 1_${ik}$
go to 10
end if
! endwhile
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_slasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
end if
50 continue
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sstedc
pure module subroutine stdlib${ii}$_dstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band real symmetric matrix can also be
!! found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See DLAED3 for details.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), e(*), z(ldz,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, &
storez, strtrw
real(dp) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'DSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( n<=smlsiz ) then
liwmin = 1_${ik}$
lwmin = 2_${ik}$*( n - 1_${ik}$ )
else
lgn = int( log( real( n,KIND=dp) )/log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( icompz==1_${ik}$ ) then
lwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'DSTEDC', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_dsterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_dsterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_dsterf( n, d, e, info )
go to 50
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_dsteqr( compz, n, d, e, z, ldz, work, info )
else
! if compz = 'v', the z matrix must be stored elsewhere for later
! use.
if( icompz==1_${ik}$ ) then
storez = 1_${ik}$ + n*n
else
storez = 1_${ik}$
end if
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, z, ldz )
end if
! scale.
orgnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( orgnrm==zero )go to 50
eps = stdlib${ii}$_dlamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
10 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
20 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 20
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m==1_${ik}$ ) then
start = finish + 1_${ik}$
go to 10
end if
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_dlanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
if( icompz==1_${ik}$ ) then
strtrw = 1_${ik}$
else
strtrw = start
end if
call stdlib${ii}$_dlaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), &
ldz, work( 1_${ik}$ ), n,work( storez ), iwork, info )
if( info/=0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 50
end if
! scale back.
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
if( icompz==1_${ik}$ ) then
! since qr won't update a z matrix which is larger than
! the length of d, we must solve the sub-problem in a
! workspace and then multiply back into z.
call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), &
info )
call stdlib${ii}$_dlacpy( 'A', n, m, z( 1_${ik}$, start ), ldz,work( storez ), n )
call stdlib${ii}$_dgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,&
z( 1_${ik}$, start ), ldz )
else if( icompz==2_${ik}$ ) then
call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, &
work, info )
else
call stdlib${ii}$_dsterf( m, d( start ), e( start ), info )
end if
if( info/=0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 50
end if
end if
start = finish + 1_${ik}$
go to 10
end if
! endwhile
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_dlasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
end if
50 continue
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dstedc
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info )
!! DSTEDC: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band real symmetric matrix can also be
!! found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See DLAED3 for details.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: d(*), e(*), z(ldz,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, &
storez, strtrw
real(${rk}$) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'DSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
liwmin = 1_${ik}$
lwmin = 1_${ik}$
else if( n<=smlsiz ) then
liwmin = 1_${ik}$
lwmin = 2_${ik}$*( n - 1_${ik}$ )
else
lgn = int( log( real( n,KIND=${rk}$) )/log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( icompz==1_${ik}$ ) then
lwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
end if
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
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( 'DSTEDC', -info )
return
else if (lquery) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_${ri}$sterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_${ri}$sterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_${ri}$sterf( n, d, e, info )
go to 50
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_${ri}$steqr( compz, n, d, e, z, ldz, work, info )
else
! if compz = 'v', the z matrix must be stored elsewhere for later
! use.
if( icompz==1_${ik}$ ) then
storez = 1_${ik}$ + n*n
else
storez = 1_${ik}$
end if
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, z, ldz )
end if
! scale.
orgnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( orgnrm==zero )go to 50
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
10 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
20 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 20
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m==1_${ik}$ ) then
start = finish + 1_${ik}$
go to 10
end if
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_${ri}$lanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
if( icompz==1_${ik}$ ) then
strtrw = 1_${ik}$
else
strtrw = start
end if
call stdlib${ii}$_${ri}$laed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), &
ldz, work( 1_${ik}$ ), n,work( storez ), iwork, info )
if( info/=0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 50
end if
! scale back.
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
if( icompz==1_${ik}$ ) then
! since qr won't update a z matrix which is larger than
! the length of d, we must solve the sub-problem in a
! workspace and then multiply back into z.
call stdlib${ii}$_${ri}$steqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), &
info )
call stdlib${ii}$_${ri}$lacpy( 'A', n, m, z( 1_${ik}$, start ), ldz,work( storez ), n )
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,&
z( 1_${ik}$, start ), ldz )
else if( icompz==2_${ik}$ ) then
call stdlib${ii}$_${ri}$steqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, &
work, info )
else
call stdlib${ii}$_${ri}$sterf( m, d( start ), e( start ), info )
end if
if( info/=0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 50
end if
end if
start = finish + 1_${ik}$
go to 10
end if
! endwhile
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_${ri}$lasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
end if
50 continue
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$stedc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cstedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, &
!! CSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See SLAED3 for details.
liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, ll, lrwmin, lwmin, m, smlsiz,&
start
real(sp) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'CSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else if( n<=smlsiz ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 2_${ik}$*( n - 1_${ik}$ )
else if( icompz==1_${ik}$ ) then
lgn = int( log( real( n,KIND=sp) ) / log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
lwmin = n*n
lrwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$ + 4_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
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( 'CSTEDC', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_ssterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_ssterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_ssterf( n, d, e, info )
go to 70
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_csteqr( compz, n, d, e, z, ldz, rwork, info )
else
! if compz = 'i', we simply call stdlib${ii}$_sstedc instead.
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, rwork, n )
ll = n*n + 1_${ik}$
call stdlib${ii}$_sstedc( 'I', n, d, e, rwork, n,rwork( ll ), lrwork-ll+1, iwork, &
liwork, info )
do j = 1, n
do i = 1, n
z( i, j ) = rwork( ( j-1 )*n+i )
end do
end do
go to 70
end if
! from now on, only option left to be handled is compz = 'v',
! i.e. icompz = 1.
! scale.
orgnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( orgnrm==zero )go to 70
eps = stdlib${ii}$_slamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
30 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
40 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 40
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_slanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
call stdlib${ii}$_claed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, &
rwork, iwork, info )
if( info>0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 70
end if
! scale back.
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), &
info )
call stdlib${ii}$_clacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )&
)
call stdlib${ii}$_clacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz )
if( info>0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 70
end if
end if
start = finish + 1_${ik}$
go to 30
end if
! endwhile
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
70 continue
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_cstedc
pure module subroutine stdlib${ii}$_zstedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, &
!! ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See DLAED3 for details.
liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, ll, lrwmin, lwmin, m, smlsiz,&
start
real(dp) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else if( n<=smlsiz ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 2_${ik}$*( n - 1_${ik}$ )
else if( icompz==1_${ik}$ ) then
lgn = int( log( real( n,KIND=dp) ) / log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
lwmin = n*n
lrwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$ + 4_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
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( 'ZSTEDC', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_dsterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_dsterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_dsterf( n, d, e, info )
go to 70
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_zsteqr( compz, n, d, e, z, ldz, rwork, info )
else
! if compz = 'i', we simply call stdlib${ii}$_dstedc instead.
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, rwork, n )
ll = n*n + 1_${ik}$
call stdlib${ii}$_dstedc( 'I', n, d, e, rwork, n,rwork( ll ), lrwork-ll+1, iwork, &
liwork, info )
do j = 1, n
do i = 1, n
z( i, j ) = rwork( ( j-1 )*n+i )
end do
end do
go to 70
end if
! from now on, only option left to be handled is compz = 'v',
! i.e. icompz = 1.
! scale.
orgnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( orgnrm==zero )go to 70
eps = stdlib${ii}$_dlamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
30 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
40 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 40
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_dlanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
call stdlib${ii}$_zlaed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, &
rwork, iwork, info )
if( info>0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 70
end if
! scale back.
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), &
info )
call stdlib${ii}$_zlacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )&
)
call stdlib${ii}$_zlacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz )
if( info>0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 70
end if
end if
start = finish + 1_${ik}$
go to 30
end if
! endwhile
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
70 continue
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zstedc
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$stedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, &
!! ZSTEDC: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
!! matrix to tridiagonal form.
!! This code 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. See DLAED3 for details.
liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, liwork, lrwork, lwork, n
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: lquery
integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, ll, lrwmin, lwmin, m, smlsiz,&
start
real(${ck}$) :: eps, orgnrm, p, tiny
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ )
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or.( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$, n ) ) ) then
info = -6_${ik}$
end if
if( info==0_${ik}$ ) then
! compute the workspace requirements
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZSTEDC', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
if( n<=1_${ik}$ .or. icompz==0_${ik}$ ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 1_${ik}$
else if( n<=smlsiz ) then
lwmin = 1_${ik}$
liwmin = 1_${ik}$
lrwmin = 2_${ik}$*( n - 1_${ik}$ )
else if( icompz==1_${ik}$ ) then
lgn = int( log( real( n,KIND=${ck}$) ) / log( two ),KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
lwmin = n*n
lrwmin = 1_${ik}$ + 3_${ik}$*n + 2_${ik}$*n*lgn + 4_${ik}$*n**2_${ik}$
liwmin = 6_${ik}$ + 6_${ik}$*n + 5_${ik}$*n*lgn
else if( icompz==2_${ik}$ ) then
lwmin = 1_${ik}$
lrwmin = 1_${ik}$ + 4_${ik}$*n + 2_${ik}$*n**2_${ik}$
liwmin = 3_${ik}$ + 5_${ik}$*n
end if
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
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( 'ZSTEDC', -info )
return
else if( lquery ) then
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz/=0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! if the following conditional clause is removed, then the routine
! will use the divide and conquer routine to compute only the
! eigenvalues, which requires (3n + 3n**2) real workspace and
! (2 + 5n + 2n lg(n)) integer workspace.
! since on many architectures stdlib${ii}$_${c2ri(ci)}$sterf is much faster than any other
! algorithm for finding eigenvalues only, it is used here
! as the default. if the conditional clause is removed, then
! information on the size of workspace needs to be changed.
! if compz = 'n', use stdlib_${c2ri(ci)}$sterf to compute the eigenvalues.
if( icompz==0_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$sterf( n, d, e, info )
go to 70
end if
! if n is smaller than the minimum divide size (smlsiz+1), then
! solve the problem with another solver.
if( n<=smlsiz ) then
call stdlib${ii}$_${ci}$steqr( compz, n, d, e, z, ldz, rwork, info )
else
! if compz = 'i', we simply call stdlib${ii}$_${c2ri(ci)}$stedc instead.
if( icompz==2_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$laset( 'FULL', n, n, zero, one, rwork, n )
ll = n*n + 1_${ik}$
call stdlib${ii}$_${c2ri(ci)}$stedc( 'I', n, d, e, rwork, n,rwork( ll ), lrwork-ll+1, iwork, &
liwork, info )
do j = 1, n
do i = 1, n
z( i, j ) = rwork( ( j-1 )*n+i )
end do
end do
go to 70
end if
! from now on, only option left to be handled is compz = 'v',
! i.e. icompz = 1.
! scale.
orgnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', n, d, e )
if( orgnrm==zero )go to 70
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
start = 1_${ik}$
! while ( start <= n )
30 continue
if( start<=n ) then
! let finish be the position of the next subdiagonal entry
! such that e( finish ) <= tiny or finish = n if no such
! subdiagonal exists. the matrix identified by the elements
! between start and finish constitutes an independent
! sub-problem.
finish = start
40 continue
if( finish<n ) then
tiny = eps*sqrt( abs( d( finish ) ) )*sqrt( abs( d( finish+1 ) ) )
if( abs( e( finish ) )>tiny ) then
finish = finish + 1_${ik}$
go to 40
end if
end if
! (sub) problem determined. compute its size and solve it.
m = finish - start + 1_${ik}$
if( m>smlsiz ) then
! scale.
orgnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', m, d( start ), e( start ) )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info )
call stdlib${ii}$_${ci}$laed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, &
rwork, iwork, info )
if( info>0_${ik}$ ) then
info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - &
1_${ik}$
go to 70
end if
! scale back.
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info )
else
call stdlib${ii}$_${c2ri(ci)}$steqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), &
info )
call stdlib${ii}$_${ci}$lacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )&
)
call stdlib${ii}$_${ci}$lacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz )
if( info>0_${ik}$ ) then
info = start*( n+1 ) + finish
go to 70
end if
end if
start = finish + 1_${ik}$
go to 30
end if
! endwhile
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
70 continue
work( 1_${ik}$ ) = lwmin
rwork( 1_${ik}$ ) = lrwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$stedc
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! SSTEGR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! SSTEGR is a compatibility wrapper around the improved SSTEMR routine.
!! See SSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : SSTEGR and SSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*)
real(sp), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_sstegr
pure module subroutine stdlib${ii}$_dstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSTEGR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! DSTEGR is a compatibility wrapper around the improved DSTEMR routine.
!! See DSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : DSTEGR and DSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*)
real(dp), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_dstegr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! DSTEGR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! DSTEGR is a compatibility wrapper around the improved DSTEMR routine.
!! See DSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : DSTEGR and DSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(${rk}$), intent(out) :: w(*), work(*)
real(${rk}$), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_${ri}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_${ri}$stegr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! CSTEGR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! CSTEGR is a compatibility wrapper around the improved CSTEMR routine.
!! See SSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : CSTEGR and CSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*)
complex(sp), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_cstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_cstegr
pure module subroutine stdlib${ii}$_zstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZSTEGR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! ZSTEGR is a compatibility wrapper around the improved ZSTEMR routine.
!! See ZSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : ZSTEGR and ZSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, 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) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*)
complex(dp), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_zstegr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, &
!! ZSTEGR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! ZSTEGR is a compatibility wrapper around the improved ZSTEMR routine.
!! See ZSTEMR for further details.
!! One important change is that the ABSTOL parameter no longer provides any
!! benefit and hence is no longer used.
!! Note : ZSTEGR and ZSTEMR work only on machines which follow
!! IEEE-754 floating-point standard in their handling of infinities and
!! NaNs. Normal execution may create these exceptiona values and hence
!! may abort due to a floating point exception in environments which
!! do not conform to the IEEE-754 standard.
isuppz, work, lwork, iwork,liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
integer(${ik}$), intent(in) :: il, iu, ldz, liwork, 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(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: w(*), work(*)
complex(${ck}$), intent(out) :: z(ldz,*)
! =====================================================================
! Local Scalars
logical(lk) :: tryrac
! Executable Statements
info = 0_${ik}$
tryrac = .false.
call stdlib${ii}$_${ci}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, &
tryrac, work, lwork,iwork, liwork, info )
end subroutine stdlib${ii}$_${ci}$stegr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! SSTEIN computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(in) :: d(*), e(*), w(*)
real(sp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Parameters
real(sp), parameter :: odm3 = 1.0e-3_sp
real(sp), parameter :: odm1 = 1.0e-1_sp
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, nblk, nrmchk
real(sp) :: ctr, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, stpcrt, tol, xj, &
xjm
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
eps = stdlib${ii}$_slamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_slarnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_160: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
stpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_150: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_160
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 120
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_slarnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_scopy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_scopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_slagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 100
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_sscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_slagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 90
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ctr = -stdlib${ii}$_sdot( blksiz, work( indrv1+1 ), 1_${ik}$, z( b1, i ),1_${ik}$ )
call stdlib${ii}$_saxpy( blksiz, ctr, z( b1, i ), 1_${ik}$,work( indrv1+1 ), 1_${ik}$ )
end do
end if
! check the infinity norm of the iterate.
90 continue
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<stpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 110
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
100 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
110 continue
scl = one / stdlib${ii}$_snrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_sscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
120 continue
do i = 1, n
z( i, j ) = zero
end do
do i = 1, blksiz
z( b1+i-1, j ) = work( indrv1+i )
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_150
end do loop_160
return
end subroutine stdlib${ii}$_sstein
pure module subroutine stdlib${ii}$_dstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! DSTEIN computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(in) :: d(*), e(*), w(*)
real(dp), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Parameters
real(dp), parameter :: odm3 = 1.0e-3_dp
real(dp), parameter :: odm1 = 1.0e-1_dp
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, nblk, nrmchk
real(dp) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, &
ztr
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
eps = stdlib${ii}$_dlamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_dlarnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_160: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
dtpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_150: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_160
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 120
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_dlarnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_dcopy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_dlagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 100
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_dscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_dlagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 90
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ztr = -stdlib${ii}$_ddot( blksiz, work( indrv1+1 ), 1_${ik}$, z( b1, i ),1_${ik}$ )
call stdlib${ii}$_daxpy( blksiz, ztr, z( b1, i ), 1_${ik}$,work( indrv1+1 ), 1_${ik}$ )
end do
end if
! check the infinity norm of the iterate.
90 continue
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<dtpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 110
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
100 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
110 continue
scl = one / stdlib${ii}$_dnrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_dscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
120 continue
do i = 1, n
z( i, j ) = zero
end do
do i = 1, blksiz
z( b1+i-1, j ) = work( indrv1+i )
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_150
end do loop_160
return
end subroutine stdlib${ii}$_dstein
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! DSTEIN: computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${rk}$), intent(in) :: d(*), e(*), w(*)
real(${rk}$), intent(out) :: work(*), z(ldz,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: odm3 = 1.0e-3_${rk}$
real(${rk}$), parameter :: odm1 = 1.0e-1_${rk}$
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, nblk, nrmchk
real(${rk}$) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, &
ztr
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! get machine constants.
eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_${ri}$larnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_160: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
dtpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_150: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_160
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 120
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_${ri}$larnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_${ri}$copy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_${ri}$lagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 100
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_i${ri}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_${ri}$scal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_${ri}$lagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 90
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ztr = -stdlib${ii}$_${ri}$dot( blksiz, work( indrv1+1 ), 1_${ik}$, z( b1, i ),1_${ik}$ )
call stdlib${ii}$_${ri}$axpy( blksiz, ztr, z( b1, i ), 1_${ik}$,work( indrv1+1 ), 1_${ik}$ )
end do
end if
! check the infinity norm of the iterate.
90 continue
jmax = stdlib${ii}$_i${ri}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<dtpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 110
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
100 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
110 continue
scl = one / stdlib${ii}$_${ri}$nrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_i${ri}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_${ri}$scal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
120 continue
do i = 1, n
z( i, j ) = zero
end do
do i = 1, blksiz
z( b1+i-1, j ) = work( indrv1+i )
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_150
end do loop_160
return
end subroutine stdlib${ii}$_${ri}$stein
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! CSTEIN computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
!! Although the eigenvectors are real, they are stored in a complex
!! array, which may be passed to CUNMTR or CUPMTR for back
!! transformation to the eigenvectors of a complex Hermitian matrix
!! which was reduced to tridiagonal form.
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(sp), intent(in) :: d(*), e(*), w(*)
real(sp), intent(out) :: work(*)
complex(sp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(sp), parameter :: odm3 = 1.0e-3_sp
real(sp), parameter :: odm1 = 1.0e-1_sp
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, jr, nblk, nrmchk
real(sp) :: ctr, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, stpcrt, tol, xj, &
xjm
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
eps = stdlib${ii}$_slamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_slarnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_180: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
stpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_170: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_180
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 140
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_slarnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_scopy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_scopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_slagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 120
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_sscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_slagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 110
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ctr = zero
do jr = 1, blksiz
ctr = ctr + work( indrv1+jr )*real( z( b1-1+jr, i ),KIND=sp)
end do
do jr = 1, blksiz
work( indrv1+jr ) = work( indrv1+jr ) -ctr*real( z( b1-1+jr, i ),&
KIND=sp)
end do
end do
end if
! check the infinity norm of the iterate.
110 continue
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<stpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 130
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
120 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
130 continue
scl = one / stdlib${ii}$_snrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_sscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
140 continue
do i = 1, n
z( i, j ) = czero
end do
do i = 1, blksiz
z( b1+i-1, j ) = cmplx( work( indrv1+i ), zero,KIND=sp)
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_170
end do loop_180
return
end subroutine stdlib${ii}$_cstein
pure module subroutine stdlib${ii}$_zstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! ZSTEIN computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
!! Although the eigenvectors are real, they are stored in a complex
!! array, which may be passed to ZUNMTR or ZUPMTR for back
!! transformation to the eigenvectors of a complex Hermitian matrix
!! which was reduced to tridiagonal form.
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(dp), intent(in) :: d(*), e(*), w(*)
real(dp), intent(out) :: work(*)
complex(dp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(dp), parameter :: odm3 = 1.0e-3_dp
real(dp), parameter :: odm1 = 1.0e-1_dp
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, jr, nblk, nrmchk
real(dp) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, &
ztr
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
eps = stdlib${ii}$_dlamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_dlarnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_180: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
dtpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_170: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_180
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 140
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_dlarnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_dcopy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_dlagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 120
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_dscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_dlagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 110
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ztr = zero
do jr = 1, blksiz
ztr = ztr + work( indrv1+jr )*real( z( b1-1+jr, i ),KIND=dp)
end do
do jr = 1, blksiz
work( indrv1+jr ) = work( indrv1+jr ) -ztr*real( z( b1-1+jr, i ),&
KIND=dp)
end do
end do
end if
! check the infinity norm of the iterate.
110 continue
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<dtpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 130
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
120 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
130 continue
scl = one / stdlib${ii}$_dnrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_dscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
140 continue
do i = 1, n
z( i, j ) = czero
end do
do i = 1, blksiz
z( b1+i-1, j ) = cmplx( work( indrv1+i ), zero,KIND=dp)
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_170
end do loop_180
return
end subroutine stdlib${ii}$_zstein
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, &
!! ZSTEIN: computes the eigenvectors of a real symmetric tridiagonal
!! matrix T corresponding to specified eigenvalues, using inverse
!! iteration.
!! The maximum number of iterations allowed for each eigenvector is
!! specified by an internal parameter MAXITS (currently set to 5).
!! Although the eigenvectors are real, they are stored in a complex
!! array, which may be passed to ZUNMTR or ZUPMTR for back
!! transformation to the eigenvectors of a complex Hermitian matrix
!! which was reduced to tridiagonal form.
info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, m, n
! Array Arguments
integer(${ik}$), intent(in) :: iblock(*), isplit(*)
integer(${ik}$), intent(out) :: ifail(*), iwork(*)
real(${ck}$), intent(in) :: d(*), e(*), w(*)
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: odm3 = 1.0e-3_${ck}$
real(${ck}$), parameter :: odm1 = 1.0e-1_${ck}$
integer(${ik}$), parameter :: maxits = 5_${ik}$
integer(${ik}$), parameter :: extra = 2_${ik}$
! Local Scalars
integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, &
indrv5, its, j, j1, jblk, jmax, jr, nblk, nrmchk
real(${ck}$) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, &
ztr
! Local Arrays
integer(${ik}$) :: iseed(4_${ik}$)
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
do i = 1, m
ifail( i ) = 0_${ik}$
end do
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( m<0_${ik}$ .or. m>n ) then
info = -4_${ik}$
else if( ldz<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else
do j = 2, m
if( iblock( j )<iblock( j-1 ) ) then
info = -6_${ik}$
go to 30
end if
if( iblock( j )==iblock( j-1 ) .and. w( j )<w( j-1 ) )then
info = -5_${ik}$
go to 30
end if
end do
30 continue
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEIN', -info )
return
end if
! quick return if possible
if( n==0_${ik}$ .or. m==0_${ik}$ ) then
return
else if( n==1_${ik}$ ) then
z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! get machine constants.
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' )
! initialize seed for random number generator stdlib${ii}$_${c2ri(ci)}$larnv.
do i = 1, 4
iseed( i ) = 1_${ik}$
end do
! initialize pointers.
indrv1 = 0_${ik}$
indrv2 = indrv1 + n
indrv3 = indrv2 + n
indrv4 = indrv3 + n
indrv5 = indrv4 + n
! compute eigenvectors of matrix blocks.
j1 = 1_${ik}$
loop_180: do nblk = 1, iblock( m )
! find starting and ending indices of block nblk.
if( nblk==1_${ik}$ ) then
b1 = 1_${ik}$
else
b1 = isplit( nblk-1 ) + 1_${ik}$
end if
bn = isplit( nblk )
blksiz = bn - b1 + 1_${ik}$
if( blksiz==1 )go to 60
gpind = j1
! compute reorthogonalization criterion and stopping criterion.
onenrm = abs( d( b1 ) ) + abs( e( b1 ) )
onenrm = max( onenrm, abs( d( bn ) )+abs( e( bn-1 ) ) )
do i = b1 + 1, bn - 1
onenrm = max( onenrm, abs( d( i ) )+abs( e( i-1 ) )+abs( e( i ) ) )
end do
ortol = odm3*onenrm
dtpcrt = sqrt( odm1 / blksiz )
! loop through eigenvalues of block nblk.
60 continue
jblk = 0_${ik}$
loop_170: do j = j1, m
if( iblock( j )/=nblk ) then
j1 = j
cycle loop_180
end if
jblk = jblk + 1_${ik}$
xj = w( j )
! skip all the work if the block size is one.
if( blksiz==1_${ik}$ ) then
work( indrv1+1 ) = one
go to 140
end if
! if eigenvalues j and j-1 are too close, add a relatively
! small perturbation.
if( jblk>1_${ik}$ ) then
eps1 = abs( eps*xj )
pertol = ten*eps1
sep = xj - xjm
if( sep<pertol )xj = xjm + pertol
end if
its = 0_${ik}$
nrmchk = 0_${ik}$
! get random starting vector.
call stdlib${ii}$_${c2ri(ci)}$larnv( 2_${ik}$, iseed, blksiz, work( indrv1+1 ) )
! copy the matrix t so it won't be destroyed in factorization.
call stdlib${ii}$_${c2ri(ci)}$copy( blksiz, d( b1 ), 1_${ik}$, work( indrv4+1 ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$copy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv2+2 ), 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$copy( blksiz-1, e( b1 ), 1_${ik}$, work( indrv3+1 ), 1_${ik}$ )
! compute lu factors with partial pivoting ( pt = lu )
tol = zero
call stdlib${ii}$_${c2ri(ci)}$lagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), tol, work( indrv5+1 ), iwork,iinfo )
! update iteration count.
70 continue
its = its + 1_${ik}$
if( its>maxits )go to 120
! normalize and scale the righthand side vector pb.
jmax = stdlib${ii}$_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+&
jmax ) )
call stdlib${ii}$_${c2ri(ci)}$scal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
! solve the system lu = pb.
call stdlib${ii}$_${c2ri(ci)}$lagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+&
1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo )
! reorthogonalize by modified gram-schmidt if eigenvalues are
! close enough.
if( jblk==1 )go to 110
if( abs( xj-xjm )>ortol )gpind = j
if( gpind/=j ) then
do i = gpind, j - 1
ztr = zero
do jr = 1, blksiz
ztr = ztr + work( indrv1+jr )*real( z( b1-1+jr, i ),KIND=${ck}$)
end do
do jr = 1, blksiz
work( indrv1+jr ) = work( indrv1+jr ) -ztr*real( z( b1-1+jr, i ),&
KIND=${ck}$)
end do
end do
end if
! check the infinity norm of the iterate.
110 continue
jmax = stdlib${ii}$_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
nrm = abs( work( indrv1+jmax ) )
! continue for additional iterations after norm reaches
! stopping criterion.
if( nrm<dtpcrt )go to 70
nrmchk = nrmchk + 1_${ik}$
if( nrmchk<extra+1 )go to 70
go to 130
! if stopping criterion was not satisfied, update info and
! store eigenvector number in array ifail.
120 continue
info = info + 1_${ik}$
ifail( info ) = j
! accept iterate as jth eigenvector.
130 continue
scl = one / stdlib${ii}$_${c2ri(ci)}$nrm2( blksiz, work( indrv1+1 ), 1_${ik}$ )
jmax = stdlib${ii}$_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ )
if( work( indrv1+jmax )<zero )scl = -scl
call stdlib${ii}$_${c2ri(ci)}$scal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ )
140 continue
do i = 1, n
z( i, j ) = czero
end do
do i = 1, blksiz
z( b1+i-1, j ) = cmplx( work( indrv1+i ), zero,KIND=${ck}$)
end do
! save the shift to check eigenvalue spacing at next
! iteration.
xjm = xj
end do loop_170
end do loop_180
return
end subroutine stdlib${ii}$_${ci}$stein
#:endif
#:endfor
pure module subroutine stdlib${ii}$_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! SSTEMR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.SSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*)
real(sp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(sp), parameter :: minrgp = 3.0e-3_sp
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(sp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_sstemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_slarre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_slarrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_slarre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_slarrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_slae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_slaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_slarrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_sscal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_slarre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_slarrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_scopy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_slarre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_slarre computes the eigenvalues to less than full precision.
! stdlib${ii}$_slarrv will refine the eigenvalue approximations, and we can
! need less accurate initial bisection in stdlib${ii}$_slarre.
! note: these settings do only affect the subset case and stdlib${ii}$_slarre
rtol1 = max( sqrt(eps)*5.0e-2_sp, four * eps )
rtol2 = max( sqrt(eps)*5.0e-3_sp, four * eps )
endif
call stdlib${ii}$_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_slarre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_slarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_slarre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_slarrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_slarre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_slarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_sscal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_slasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_sstemr
pure module subroutine stdlib${ii}$_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! DSTEMR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.DSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*)
real(dp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(dp), parameter :: minrgp = 1.0e-3_dp
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(dp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_dstemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_dlarre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_dlarrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_dlarre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_dlarrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_dlae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_dlaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_dlarrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_dscal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_dlarre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_dlarrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_dcopy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_dlarre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_dlarre computes the eigenvalues to less than full precision.
! stdlib${ii}$_dlarrv will refine the eigenvalue approximations, and we can
! need less accurate initial bisection in stdlib${ii}$_dlarre.
! note: these settings do only affect the subset case and stdlib${ii}$_dlarre
rtol1 = sqrt(eps)
rtol2 = max( sqrt(eps)*5.0e-3_dp, four * eps )
endif
call stdlib${ii}$_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_dlarre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_dlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_dlarre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_dlarrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_dlarre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_dlarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_dscal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_dlasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_dstemr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! DSTEMR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.DSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${rk}$), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(${rk}$), intent(inout) :: d(*), e(*)
real(${rk}$), intent(out) :: w(*), work(*)
real(${rk}$), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: minrgp = 1.0e-3_${rk}$
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(${rk}$) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_${ri}$stemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_${ri}$larre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_${ri}$larrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_${ri}$larre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_${ri}$larrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_${ri}$lae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_${ri}$laev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_${ri}$larrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$scal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_${ri}$larre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_${ri}$larrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_${ri}$copy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_${ri}$larre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_${ri}$larre computes the eigenvalues to less than full precision.
! stdlib${ii}$_${ri}$larrv will refine the eigenvalue approximations, and we can
! need less accurate initial bisection in stdlib${ii}$_${ri}$larre.
! note: these settings do only affect the subset case and stdlib${ii}$_${ri}$larre
rtol1 = sqrt(eps)
rtol2 = max( sqrt(eps)*5.0e-3_${rk}$, four * eps )
endif
call stdlib${ii}$_${ri}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_${ri}$larre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_${ri}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_${ri}$larre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_${ri}$larrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_${ri}$larre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_${ri}$larrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_${ri}$scal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_${ri}$lasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ri}$stemr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_cstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! CSTEMR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.CSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
!! 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
!! real symmetric tridiagonal form.
!! (Any complex Hermitean tridiagonal matrix has real values on its diagonal
!! and potentially complex numbers on its off-diagonals. By applying a
!! similarity transform with an appropriate diagonal matrix
!! diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
!! matrix can be transformed into a real symmetric matrix and complex
!! arithmetic can be entirely avoided.)
!! While the eigenvectors of the real symmetric tridiagonal matrix are real,
!! the eigenvectors of original complex Hermitean matrix have complex entries
!! in general.
!! Since LAPACK drivers overwrite the matrix data with the eigenvectors,
!! CSTEMR accepts complex workspace to facilitate interoperability
!! with CUNMTR or CUPMTR.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(sp), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: w(*), work(*)
complex(sp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(sp), parameter :: minrgp = 3.0e-3_sp
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(sp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_sstemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_slarre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_clarrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_slarre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_slarrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_slae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_slaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_slarrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_slanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_sscal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_sscal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_slarre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_slarrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_scopy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_slarre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_slarre computes the eigenvalues to less than full precision.
! stdlib${ii}$_clarrv will refine the eigenvalue approximations, and we only
! need less accurate initial bisection in stdlib${ii}$_slarre.
! note: these settings do only affect the subset case and stdlib${ii}$_slarre
rtol1 = max( sqrt(eps)*5.0e-2_sp, four * eps )
rtol2 = max( sqrt(eps)*5.0e-3_sp, four * eps )
endif
call stdlib${ii}$_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_slarre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_clarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_slarre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_clarrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_slarre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_slarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_sscal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_slasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_cstemr
pure module subroutine stdlib${ii}$_zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! ZSTEMR computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.ZSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
!! 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
!! real symmetric tridiagonal form.
!! (Any complex Hermitean tridiagonal matrix has real values on its diagonal
!! and potentially complex numbers on its off-diagonals. By applying a
!! similarity transform with an appropriate diagonal matrix
!! diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
!! matrix can be transformed into a real symmetric matrix and complex
!! arithmetic can be entirely avoided.)
!! While the eigenvectors of the real symmetric tridiagonal matrix are real,
!! the eigenvectors of original complex Hermitean matrix have complex entries
!! in general.
!! Since LAPACK drivers overwrite the matrix data with the eigenvectors,
!! ZSTEMR accepts complex workspace to facilitate interoperability
!! with ZUNMTR or ZUPMTR.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(dp), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: w(*), work(*)
complex(dp), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(dp), parameter :: minrgp = 1.0e-3_dp
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(dp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_dstemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_dlarre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_zlarrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_dlarre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_dlarrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_dlae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_dlaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_dlarrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_dlanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_dscal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_dscal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_dlarre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_dlarrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_dcopy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_dlarre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_dlarre computes the eigenvalues to less than full precision.
! stdlib${ii}$_zlarrv will refine the eigenvalue approximations, and we only
! need less accurate initial bisection in stdlib${ii}$_dlarre.
! note: these settings do only affect the subset case and stdlib${ii}$_dlarre
rtol1 = sqrt(eps)
rtol2 = max( sqrt(eps)*5.0e-3_dp, four * eps )
endif
call stdlib${ii}$_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_dlarre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_zlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_dlarre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_zlarrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_dlarre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_dlarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_dscal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_dlasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_zstemr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, &
!! ZSTEMR: computes selected eigenvalues and, optionally, eigenvectors
!! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
!! a well defined set of pairwise different real eigenvalues, the corresponding
!! real eigenvectors are pairwise orthogonal.
!! The spectrum may be computed either completely or partially by specifying
!! either an interval (VL,VU] or a range of indices IL:IU for the desired
!! eigenvalues.
!! Depending on the number of desired eigenvalues, these are computed either
!! by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
!! computed by the use of various suitable L D L^T factorizations near clusters
!! of close eigenvalues (referred to as RRRs, Relatively Robust
!! Representations). An informal sketch of the algorithm 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.
!! For more details, see:
!! - 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.
!! Further Details
!! 1.ZSTEMR works only on machines which follow IEEE-754
!! floating-point standard in their handling of infinities and NaNs.
!! This permits the use of efficient inner loops avoiding a check for
!! zero divisors.
!! 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
!! real symmetric tridiagonal form.
!! (Any complex Hermitean tridiagonal matrix has real values on its diagonal
!! and potentially complex numbers on its off-diagonals. By applying a
!! similarity transform with an appropriate diagonal matrix
!! diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
!! matrix can be transformed into a real symmetric matrix and complex
!! arithmetic can be entirely avoided.)
!! While the eigenvectors of the real symmetric tridiagonal matrix are real,
!! the eigenvectors of original complex Hermitean matrix have complex entries
!! in general.
!! Since LAPACK drivers overwrite the matrix data with the eigenvectors,
!! ZSTEMR accepts complex workspace to facilitate interoperability
!! with ZUNMTR or ZUPMTR.
isuppz, tryrac, work, lwork,iwork, liwork, info )
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: jobz, range
logical(lk), intent(inout) :: tryrac
integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n
integer(${ik}$), intent(out) :: info, m
real(${ck}$), intent(in) :: vl, vu
! Array Arguments
integer(${ik}$), intent(out) :: isuppz(*), iwork(*)
real(${ck}$), intent(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: w(*), work(*)
complex(${ck}$), intent(out) :: z(ldz,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: minrgp = 1.0e-3_${ck}$
! Local Scalars
logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery
integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, &
iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, &
liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend
real(${ck}$) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, &
smlnum, sn, thresh, tmp, tnrm, wl, wu
! 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' )
lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) )
zquery = ( nzc==-1_${ik}$ )
! stdlib${ii}$_${c2ri(ci)}$stemr needs work of size 6*n, iwork of size 3*n.
! in addition, stdlib${ii}$_${c2ri(ci)}$larre needs work of size 6*n, iwork of size 5*n.
! furthermore, stdlib${ii}$_${ci}$larrv needs work of size 12*n, iwork of size 7*n.
if( wantz ) then
lwmin = 18_${ik}$*n
liwmin = 10_${ik}$*n
else
! need less workspace if only the eigenvalues are wanted
lwmin = 12_${ik}$*n
liwmin = 8_${ik}$*n
endif
wl = zero
wu = zero
iil = 0_${ik}$
iiu = 0_${ik}$
nsplit = 0_${ik}$
if( valeig ) then
! we do not reference vl, vu in the cases range = 'i','a'
! the interval (wl, wu] contains all the wanted eigenvalues.
! it is either given by the user or computed in stdlib${ii}$_${c2ri(ci)}$larre.
wl = vl
wu = vu
elseif( indeig ) then
! we do not reference il, iu in the cases range = 'v','a'
iil = il
iiu = iu
endif
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( n<0_${ik}$ ) then
info = -3_${ik}$
else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then
info = -7_${ik}$
else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then
info = -8_${ik}$
else if( indeig .and. ( iiu<iil .or. iiu>n ) ) then
info = -9_${ik}$
else if( ldz<1_${ik}$ .or. ( wantz .and. ldz<n ) ) then
info = -13_${ik}$
else if( lwork<lwmin .and. .not.lquery ) then
info = -17_${ik}$
else if( liwork<liwmin .and. .not.lquery ) then
info = -19_${ik}$
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 ) ) )
if( info==0_${ik}$ ) then
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
if( wantz .and. alleig ) then
nzcmin = n
else if( wantz .and. valeig ) then
call stdlib${ii}$_${c2ri(ci)}$larrc( 'T', n, vl, vu, d, e, safmin,nzcmin, itmp, itmp2, info )
else if( wantz .and. indeig ) then
nzcmin = iiu-iil+1
else
! wantz == false.
nzcmin = 0_${ik}$
endif
if( zquery .and. info==0_${ik}$ ) then
z( 1_${ik}$,1_${ik}$ ) = nzcmin
else if( nzc<nzcmin .and. .not.zquery ) then
info = -14_${ik}$
end if
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEMR', -info )
return
else if( lquery .or. zquery ) then
return
end if
! handle n = 0, 1, and 2 cases immediately
m = 0_${ik}$
if( n==0 )return
if( n==1_${ik}$ ) then
if( alleig .or. indeig ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
else
if( wl<d( 1_${ik}$ ) .and. wu>=d( 1_${ik}$ ) ) then
m = 1_${ik}$
w( 1_${ik}$ ) = d( 1_${ik}$ )
end if
end if
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, 1_${ik}$ ) = one
isuppz(1_${ik}$) = 1_${ik}$
isuppz(2_${ik}$) = 1_${ik}$
end if
return
end if
if( n==2_${ik}$ ) then
if( .not.wantz ) then
call stdlib${ii}$_${c2ri(ci)}$lae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 )
else if( wantz.and.(.not.zquery) ) then
call stdlib${ii}$_${c2ri(ci)}$laev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn )
end if
if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) &
then
m = m+1
w( m ) = r2
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = -sn
z( 2_${ik}$, m ) = cs
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) &
then
m = m+1
w( m ) = r1
if( wantz.and.(.not.zquery) ) then
z( 1_${ik}$, m ) = cs
z( 2_${ik}$, m ) = sn
! note: at most one of sn and cs can be zero.
if (sn/=zero) then
if (cs/=zero) then
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
else
isuppz(2_${ik}$*m-1) = 1_${ik}$
isuppz(2_${ik}$*m) = 1_${ik}$
end if
else
isuppz(2_${ik}$*m-1) = 2_${ik}$
isuppz(2_${ik}$*m) = 2_${ik}$
end if
endif
endif
else
! continue with general n
indgrs = 1_${ik}$
inderr = 2_${ik}$*n + 1_${ik}$
indgp = 3_${ik}$*n + 1_${ik}$
indd = 4_${ik}$*n + 1_${ik}$
inde2 = 5_${ik}$*n + 1_${ik}$
indwrk = 6_${ik}$*n + 1_${ik}$
iinspl = 1_${ik}$
iindbl = n + 1_${ik}$
iindw = 2_${ik}$*n + 1_${ik}$
iindwk = 3_${ik}$*n + 1_${ik}$
! scale matrix to allowable range, if necessary.
! the allowable range is related to the pivmin parameter; see the
! comments in stdlib${ii}$_${c2ri(ci)}$larrd. the preference for scaling small values
! up is heuristic; we expect users' matrices not to be close to the
! rmax threshold.
scale = one
tnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', n, d, e )
if( tnrm>zero .and. tnrm<rmin ) then
scale = rmin / tnrm
else if( tnrm>rmax ) then
scale = rmax / tnrm
end if
if( scale/=one ) then
call stdlib${ii}$_${c2ri(ci)}$scal( n, scale, d, 1_${ik}$ )
call stdlib${ii}$_${c2ri(ci)}$scal( n-1, scale, e, 1_${ik}$ )
tnrm = tnrm*scale
if( valeig ) then
! if eigenvalues in interval have to be found,
! scale (wl, wu] accordingly
wl = wl*scale
wu = wu*scale
endif
end if
! compute the desired eigenvalues of the tridiagonal after splitting
! into smaller subblocks if the corresponding off-diagonal elements
! are small
! thresh is the splitting parameter for stdlib${ii}$_${c2ri(ci)}$larre
! a negative thresh forces the old splitting criterion based on the
! size of the off-diagonal. a positive thresh switches to splitting
! which preserves relative accuracy.
if( tryrac ) then
! test whether the matrix warrants the more expensive relative approach.
call stdlib${ii}$_${c2ri(ci)}$larrr( n, d, e, iinfo )
else
! the user does not care about relative accurately eigenvalues
iinfo = -1_${ik}$
endif
! set the splitting criterion
if (iinfo==0_${ik}$) then
thresh = eps
else
thresh = -eps
! relative accuracy is desired but t does not guarantee it
tryrac = .false.
endif
if( tryrac ) then
! copy original diagonal, needed to guarantee relative accuracy
call stdlib${ii}$_${c2ri(ci)}$copy(n,d,1_${ik}$,work(indd),1_${ik}$)
endif
! store the squares of the offdiagonal values of t
do j = 1, n-1
work( inde2+j-1 ) = e(j)**2_${ik}$
end do
! set the tolerance parameters for bisection
if( .not.wantz ) then
! stdlib${ii}$_${c2ri(ci)}$larre computes the eigenvalues to full precision.
rtol1 = four * eps
rtol2 = four * eps
else
! stdlib${ii}$_${c2ri(ci)}$larre computes the eigenvalues to less than full precision.
! stdlib${ii}$_${ci}$larrv will refine the eigenvalue approximations, and we only
! need less accurate initial bisection in stdlib${ii}$_${c2ri(ci)}$larre.
! note: these settings do only affect the subset case and stdlib${ii}$_${c2ri(ci)}$larre
rtol1 = sqrt(eps)
rtol2 = max( sqrt(eps)*5.0e-3_${ck}$, four * eps )
endif
call stdlib${ii}$_${c2ri(ci)}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, &
thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),&
iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 10_${ik}$ + abs( iinfo )
return
end if
! note that if range /= 'v', stdlib${ii}$_${c2ri(ci)}$larre computes bounds on the desired
! part of the spectrum. all desired eigenvalues are contained in
! (wl,wu]
if( wantz ) then
! compute the desired eigenvectors corresponding to the computed
! eigenvalues
call stdlib${ii}$_${ci}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, &
rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), &
work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo )
if( iinfo/=0_${ik}$ ) then
info = 20_${ik}$ + abs( iinfo )
return
end if
else
! stdlib${ii}$_${c2ri(ci)}$larre computes eigenvalues of the (shifted) root representation
! stdlib${ii}$_${ci}$larrv returns the eigenvalues of the unshifted matrix.
! however, if the eigenvectors are not desired by the user, we need
! to apply the corresponding shifts from stdlib${ii}$_${c2ri(ci)}$larre to obtain the
! eigenvalues of the original matrix.
do j = 1, m
itmp = iwork( iindbl+j-1 )
w( j ) = w( j ) + e( iwork( iinspl+itmp-1 ) )
end do
end if
if ( tryrac ) then
! refine computed eigenvalues so that they are relatively accurate
! with respect to the original matrix t.
ibegin = 1_${ik}$
wbegin = 1_${ik}$
loop_39: do jblk = 1, iwork( iindbl+m-1 )
iend = iwork( iinspl+jblk-1 )
in = iend - ibegin + 1_${ik}$
wend = wbegin - 1_${ik}$
! check if any eigenvalues have to be refined in this block
36 continue
if( wend<m ) then
if( iwork( iindbl+wend )==jblk ) then
wend = wend + 1_${ik}$
go to 36
end if
end if
if( wend<wbegin ) then
ibegin = iend + 1_${ik}$
cycle loop_39
end if
offset = iwork(iindw+wbegin-1)-1_${ik}$
ifirst = iwork(iindw+wbegin-1)
ilast = iwork(iindw+wend-1)
rtol2 = four * eps
call stdlib${ii}$_${c2ri(ci)}$larrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, &
ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(&
iindwk ), pivmin,tnrm, iinfo )
ibegin = iend + 1_${ik}$
wbegin = wend + 1_${ik}$
end do loop_39
endif
! if matrix was scaled, then rescale eigenvalues appropriately.
if( scale/=one ) then
call stdlib${ii}$_${c2ri(ci)}$scal( m, one / scale, w, 1_${ik}$ )
end if
end if
! if eigenvalues are not in increasing order, then sort them,
! possibly along with eigenvectors.
if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then
if( .not. wantz ) then
call stdlib${ii}$_${c2ri(ci)}$lasrt( 'I', m, w, iinfo )
if( iinfo/=0_${ik}$ ) then
info = 3_${ik}$
return
end if
else
do j = 1, m - 1
i = 0_${ik}$
tmp = w( j )
do jj = j + 1, m
if( w( jj )<tmp ) then
i = jj
tmp = w( jj )
end if
end do
if( i/=0_${ik}$ ) then
w( i ) = w( j )
w( j ) = tmp
if( wantz ) then
call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, j ), 1_${ik}$ )
itmp = isuppz( 2_${ik}$*i-1 )
isuppz( 2_${ik}$*i-1 ) = isuppz( 2_${ik}$*j-1 )
isuppz( 2_${ik}$*j-1 ) = itmp
itmp = isuppz( 2_${ik}$*i )
isuppz( 2_${ik}$*i ) = isuppz( 2_${ik}$*j )
isuppz( 2_${ik}$*j ) = itmp
end if
end if
end do
end if
endif
work( 1_${ik}$ ) = lwmin
iwork( 1_${ik}$ ) = liwmin
return
end subroutine stdlib${ii}$_${ci}$stemr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_ssteqr( compz, n, d, e, z, ldz, work, info )
!! SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band symmetric matrix can also be found
!! if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
!! tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*), z(ldz,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(sp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_slamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_slanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_slasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_slapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_slartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_slasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_slasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_slapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_slartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_slasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 190
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_slasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
190 continue
return
end subroutine stdlib${ii}$_ssteqr
pure module subroutine stdlib${ii}$_dsteqr( compz, n, d, e, z, ldz, work, info )
!! DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band symmetric matrix can also be found
!! if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
!! tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*), z(ldz,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(dp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_dlamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_dlanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_dlasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_dlapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_dlartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_dlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_dlasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_dlapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_dlartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_dlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 190
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_dlasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
190 continue
return
end subroutine stdlib${ii}$_dsteqr
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$steqr( compz, n, d, e, z, ldz, work, info )
!! DSTEQR: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band symmetric matrix can also be found
!! if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
!! tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(${rk}$), intent(inout) :: d(*), e(*), z(ldz,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(${rk}$) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_${ri}$lamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_${ri}$lamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_${ri}$lanst( 'M', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_${ri}$lae2 or stdlib${ii}$_dlaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_${ri}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_${ri}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_${ri}$lapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_${ri}$lartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_${ri}$lae2 or stdlib${ii}$_dlaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_${ri}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_${ri}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_${ri}$lapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_${ri}$lartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot<nmaxit )go to 10
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
go to 190
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_${ri}$lasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_${ri}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
190 continue
return
end subroutine stdlib${ii}$_${ri}$steqr
#:endif
#:endfor
pure module subroutine stdlib${ii}$_csteqr( compz, n, d, e, z, ldz, work, info )
!! CSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this
!! matrix to tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: work(*)
complex(sp), intent(inout) :: z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(sp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_slamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_slamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_slanst( 'I', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_clasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_slapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_slartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_clasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_clasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_slapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_slartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_clasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot==nmaxit ) then
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
return
end if
go to 10
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_slasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_csteqr
pure module subroutine stdlib${ii}$_zsteqr( compz, n, d, e, z, ldz, work, info )
!! ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
!! matrix to tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: work(*)
complex(dp), intent(inout) :: z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(dp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_dlamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_dlamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_dlanst( 'I', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_zlasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_dlapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_dlartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_zlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib${ii}$_slaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_zlasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_dlapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_dlartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_zlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot==nmaxit ) then
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
return
end if
go to 10
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_dlasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_zsteqr
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$steqr( compz, n, d, e, z, ldz, work, info )
!! ZSTEQR: computes all eigenvalues and, optionally, eigenvectors of a
!! symmetric tridiagonal matrix using the implicit QL or QR method.
!! The eigenvectors of a full or band complex Hermitian matrix can also
!! be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
!! matrix to tridiagonal form.
! -- lapack computational routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: compz
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: ldz, n
! Array Arguments
real(${ck}$), intent(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: work(*)
complex(${ck}$), intent(inout) :: z(ldz,*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
integer(${ik}$) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,&
lm1, lsv, m, mm, mm1, nm1, nmaxit
real(${ck}$) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, &
ssfmin, tst
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( stdlib_lsame( compz, 'N' ) ) then
icompz = 0_${ik}$
else if( stdlib_lsame( compz, 'V' ) ) then
icompz = 1_${ik}$
else if( stdlib_lsame( compz, 'I' ) ) then
icompz = 2_${ik}$
else
icompz = -1_${ik}$
end if
if( icompz<0_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ( ldz<1_${ik}$ ) .or. ( icompz>0_${ik}$ .and. ldz<max( 1_${ik}$,n ) ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZSTEQR', -info )
return
end if
! quick return if possible
if( n==0 )return
if( n==1_${ik}$ ) then
if( icompz==2_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone
return
end if
! determine the unit roundoff and over/underflow thresholds.
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )
eps2 = eps**2_${ik}$
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' )
safmax = one / safmin
ssfmax = sqrt( safmax ) / three
ssfmin = sqrt( safmin ) / eps2
! compute the eigenvalues and eigenvectors of the tridiagonal
! matrix.
if( icompz==2_${ik}$ )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz )
nmaxit = n*maxit
jtot = 0_${ik}$
! determine where the matrix splits and choose ql or qr iteration
! for each block, according to whether top or bottom diagonal
! element is smaller.
l1 = 1_${ik}$
nm1 = n - 1_${ik}$
10 continue
if( l1>n )go to 160
if( l1>1_${ik}$ )e( l1-1 ) = zero
if( l1<=nm1 ) then
do m = l1, nm1
tst = abs( e( m ) )
if( tst==zero )go to 30
if( tst<=( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+1 ) ) ) )*eps ) then
e( m ) = zero
go to 30
end if
end do
end if
m = n
30 continue
l = l1
lsv = l
lend = m
lendsv = lend
l1 = m + 1_${ik}$
if( lend==l )go to 10
! scale submatrix in rows and columns l to lend
anorm = stdlib${ii}$_${c2ri(ci)}$lanst( 'I', lend-l+1, d( l ), e( l ) )
iscale = 0_${ik}$
if( anorm==zero )go to 10
if( anorm>ssfmax ) then
iscale = 1_${ik}$
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info )
else if( anorm<ssfmin ) then
iscale = 2_${ik}$
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l+1, 1_${ik}$, d( l ), n,info )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmin, lend-l, 1_${ik}$, e( l ), n,info )
end if
! choose between ql and qr iteration
if( abs( d( lend ) )<abs( d( l ) ) ) then
lend = lsv
l = lendsv
end if
if( lend>l ) then
! ql iteration
! look for small subdiagonal element.
40 continue
if( l/=lend ) then
lendm1 = lend - 1_${ik}$
do m = l, lendm1
tst = abs( e( m ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+safmin )go to 60
end do
end if
m = lend
60 continue
if( m<lend )e( m ) = zero
p = d( l )
if( m==l )go to 80
! if remaining matrix is 2-by-2, use stdlib_${c2ri(ci)}$lae2 or stdlib${ii}$_dlaev2
! to compute its eigensystem.
if( m==l+1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
work( l ) = c
work( n-1+l ) = s
call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), &
ldz )
else
call stdlib${ii}$_${c2ri(ci)}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
end if
d( l ) = rt1
d( l+1 ) = rt2
e( l ) = zero
l = l + 2_${ik}$
if( l<=lend )go to 40
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l+1 )-p ) / ( two*e( l ) )
r = stdlib${ii}$_${c2ri(ci)}$lapy2( g, one )
g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
mm1 = m - 1_${ik}$
do i = mm1, l, -1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_${c2ri(ci)}$lartg( g, f, c, s, r )
if( i/=m-1 )e( i+1 ) = r
g = d( i+1 ) - p
r = ( d( i )-g )*s + two*c*b
p = s*r
d( i+1 ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = -s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = m - l + 1_${ik}$
call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz &
)
end if
d( l ) = d( l ) - p
e( l ) = g
go to 40
! eigenvalue found.
80 continue
d( l ) = p
l = l + 1_${ik}$
if( l<=lend )go to 40
go to 140
else
! qr iteration
! look for small superdiagonal element.
90 continue
if( l/=lend ) then
lendp1 = lend + 1_${ik}$
do m = l, lendp1, -1
tst = abs( e( m-1 ) )**2_${ik}$
if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110
end do
end if
m = lend
110 continue
if( m>lend )e( m-1 ) = zero
p = d( l )
if( m==l )go to 130
! if remaining matrix is 2-by-2, use stdlib_${c2ri(ci)}$lae2 or stdlib${ii}$_dlaev2
! to compute its eigensystem.
if( m==l-1 ) then
if( icompz>0_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
work( m ) = c
work( n-1+m ) = s
call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), &
ldz )
else
call stdlib${ii}$_${c2ri(ci)}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
end if
d( l-1 ) = rt1
d( l ) = rt2
e( l-1 ) = zero
l = l - 2_${ik}$
if( l>=lend )go to 90
go to 140
end if
if( jtot==nmaxit )go to 140
jtot = jtot + 1_${ik}$
! form shift.
g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
r = stdlib${ii}$_${c2ri(ci)}$lapy2( g, one )
g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
s = one
c = one
p = zero
! inner loop
lm1 = l - 1_${ik}$
do i = m, lm1
f = s*e( i )
b = c*e( i )
call stdlib${ii}$_${c2ri(ci)}$lartg( g, f, c, s, r )
if( i/=m )e( i-1 ) = r
g = d( i ) - p
r = ( d( i+1 )-g )*s + two*c*b
p = s*r
d( i ) = g + p
g = c*r - b
! if eigenvectors are desired, then save rotations.
if( icompz>0_${ik}$ ) then
work( i ) = c
work( n-1+i ) = s
end if
end do
! if eigenvectors are desired, then apply saved rotations.
if( icompz>0_${ik}$ ) then
mm = l - m + 1_${ik}$
call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz &
)
end if
d( l ) = d( l ) - p
e( lm1 ) = g
go to 90
! eigenvalue found.
130 continue
d( l ) = p
l = l - 1_${ik}$
if( l>=lend )go to 90
go to 140
end if
! undo scaling if necessary
140 continue
if( iscale==1_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
else if( iscale==2_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info )
call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info )
end if
! check for no convergence to an eigenvalue after a total
! of n*maxit iterations.
if( jtot==nmaxit ) then
do i = 1, n - 1
if( e( i )/=zero )info = info + 1_${ik}$
end do
return
end if
go to 10
! order eigenvalues and eigenvectors.
160 continue
if( icompz==0_${ik}$ ) then
! use quick sort
call stdlib${ii}$_${c2ri(ci)}$lasrt( 'I', n, d, info )
else
! use selection sort to minimize swaps of eigenvectors
do ii = 2, n
i = ii - 1_${ik}$
k = i
p = d( i )
do j = ii, n
if( d( j )<p ) then
k = j
p = d( j )
end if
end do
if( k/=i ) then
d( k ) = d( i )
d( i ) = p
call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$steqr
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_tridiag3
