#:include "common.fypp"
submodule(stdlib_lapack_eig_svd_lsq) stdlib_lapack_eigv_tridiag
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_slaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, d, &
!! SLAEBZ contains the iteration loops which compute and use the
!! function N(w), which is the count of eigenvalues of a symmetric
!! tridiagonal matrix T less than or equal to its argument w. It
!! performs a choice of two types of loops:
!! IJOB=1, followed by
!! IJOB=2: It takes as input a list of intervals and returns a list of
!! sufficiently small intervals whose union contains the same
!! eigenvalues as the union of the original intervals.
!! The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
!! The output interval (AB(j,1),AB(j,2)] will contain
!! eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
!! IJOB=3: It performs a binary search in each input interval
!! (AB(j,1),AB(j,2)] for a point w(j) such that
!! N(w(j))=NVAL(j), and uses C(j) as the starting point of
!! the search. If such a w(j) is found, then on output
!! AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
!! (AB(j,1),AB(j,2)] will be a small interval containing the
!! point where N(w) jumps through NVAL(j), unless that point
!! lies outside the initial interval.
!! Note that the intervals are in all cases half-open intervals,
!! i.e., of the form (a,b] , which includes b but not a .
!! To avoid underflow, the matrix should be scaled so that its largest
!! element is no greater than overflow**(1/2) * underflow**(1/4)
!! in absolute value. To assure the most accurate computation
!! of small eigenvalues, the matrix should be scaled to be
!! not much smaller than that, either.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966
!! Note: the arguments are, in general, *not* checked for unreasonable
!! values.
e, e2, nval, ab, c, mout,nab, work, iwork, info )
! -- lapack auxiliary 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(in) :: ijob, minp, mmax, n, nbmin, nitmax
integer(${ik}$), intent(out) :: info, mout
real(sp), intent(in) :: abstol, pivmin, reltol
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(inout) :: nab(mmax,*), nval(*)
real(sp), intent(inout) :: ab(mmax,*), c(*)
real(sp), intent(in) :: d(*), e(*), e2(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: itmp1, itmp2, j, ji, jit, jp, kf, kfnew, kl, klnew
real(sp) :: tmp1, tmp2
! Intrinsic Functions
! Executable Statements
! check for errors
info = 0_${ik}$
if( ijob<1_${ik}$ .or. ijob>3_${ik}$ ) then
info = -1_${ik}$
return
end if
! initialize nab
if( ijob==1_${ik}$ ) then
! compute the number of eigenvalues in the initial intervals.
mout = 0_${ik}$
do ji = 1, minp
do jp = 1, 2
tmp1 = d( 1_${ik}$ ) - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
nab( ji, jp ) = 0_${ik}$
if( tmp1<=zero )nab( ji, jp ) = 1_${ik}$
do j = 2, n
tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
if( tmp1<=zero )nab( ji, jp ) = nab( ji, jp ) + 1_${ik}$
end do
end do
mout = mout + nab( ji, 2_${ik}$ ) - nab( ji, 1_${ik}$ )
end do
return
end if
! initialize for loop
! kf and kl have the following meaning:
! intervals 1,...,kf-1 have converged.
! intervals kf,...,kl still need to be refined.
kf = 1_${ik}$
kl = minp
! if ijob=2, initialize c.
! if ijob=3, use the user-supplied starting point.
if( ijob==2_${ik}$ ) then
do ji = 1, minp
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
end if
! iteration loop
loop_130: do jit = 1, nitmax
! loop over intervals
if( kl-kf+1>=nbmin .and. nbmin>0_${ik}$ ) then
! begin of parallel version of the loop
do ji = kf, kl
! compute n(c), the number of eigenvalues less than c
work( ji ) = d( 1_${ik}$ ) - c( ji )
iwork( ji ) = 0_${ik}$
if( work( ji )<=pivmin ) then
iwork( ji ) = 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
do j = 2, n
work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji )
if( work( ji )<=pivmin ) then
iwork( ji ) = iwork( ji ) + 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
end do
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
klnew = kl
loop_70: do ji = kf, kl
! insure that n(w) is monotone
iwork( ji ) = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), iwork( ji ) ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( iwork( ji )==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = c( ji )
else if( iwork( ji )==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = c( ji )
else
klnew = klnew + 1_${ik}$
if( klnew<=mmax ) then
! eigenvalue in both intervals -- add upper to
! queue.
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = c( ji )
nab( klnew, 1_${ik}$ ) = iwork( ji )
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
else
info = mmax + 1_${ik}$
end if
end if
end do loop_70
if( info/=0 )return
kl = klnew
else
! ijob=3: binary search. keep only the interval containing
! w s.t. n(w) = nval
do ji = kf, kl
if( iwork( ji )<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = c( ji )
nab( ji, 1_${ik}$ ) = iwork( ji )
end if
if( iwork( ji )>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
end if
end do
end if
else
! end of parallel version of the loop
! begin of serial version of the loop
klnew = kl
loop_100: do ji = kf, kl
! compute n(w), the number of eigenvalues less than w
tmp1 = c( ji )
tmp2 = d( 1_${ik}$ ) - tmp1
itmp1 = 0_${ik}$
if( tmp2<=pivmin ) then
itmp1 = 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
do j = 2, n
tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1
if( tmp2<=pivmin ) then
itmp1 = itmp1 + 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
! insure that n(w) is monotone
itmp1 = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), itmp1 ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( itmp1==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = tmp1
else if( itmp1==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = tmp1
else if( klnew<mmax ) then
! eigenvalue in both intervals -- add upper to queue.
klnew = klnew + 1_${ik}$
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = tmp1
nab( klnew, 1_${ik}$ ) = itmp1
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
else
info = mmax + 1_${ik}$
return
end if
else
! ijob=3: binary search. keep only the interval
! containing w s.t. n(w) = nval
if( itmp1<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = tmp1
nab( ji, 1_${ik}$ ) = itmp1
end if
if( itmp1>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
end if
end if
end do loop_100
kl = klnew
end if
! check for convergence
kfnew = kf
loop_110: do ji = kf, kl
tmp1 = abs( ab( ji, 2_${ik}$ )-ab( ji, 1_${ik}$ ) )
tmp2 = max( abs( ab( ji, 2_${ik}$ ) ), abs( ab( ji, 1_${ik}$ ) ) )
if( tmp1<max( abstol, pivmin, reltol*tmp2 ) .or.nab( ji, 1_${ik}$ )>=nab( ji, 2_${ik}$ ) ) &
then
! converged -- swap with position kfnew,
! then increment kfnew
if( ji>kfnew ) then
tmp1 = ab( ji, 1_${ik}$ )
tmp2 = ab( ji, 2_${ik}$ )
itmp1 = nab( ji, 1_${ik}$ )
itmp2 = nab( ji, 2_${ik}$ )
ab( ji, 1_${ik}$ ) = ab( kfnew, 1_${ik}$ )
ab( ji, 2_${ik}$ ) = ab( kfnew, 2_${ik}$ )
nab( ji, 1_${ik}$ ) = nab( kfnew, 1_${ik}$ )
nab( ji, 2_${ik}$ ) = nab( kfnew, 2_${ik}$ )
ab( kfnew, 1_${ik}$ ) = tmp1
ab( kfnew, 2_${ik}$ ) = tmp2
nab( kfnew, 1_${ik}$ ) = itmp1
nab( kfnew, 2_${ik}$ ) = itmp2
if( ijob==3_${ik}$ ) then
itmp1 = nval( ji )
nval( ji ) = nval( kfnew )
nval( kfnew ) = itmp1
end if
end if
kfnew = kfnew + 1_${ik}$
end if
end do loop_110
kf = kfnew
! choose midpoints
do ji = kf, kl
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
! if no more intervals to refine, quit.
if( kf>kl )go to 140
end do loop_130
! converged
140 continue
info = max( kl+1-kf, 0_${ik}$ )
mout = kl
return
end subroutine stdlib${ii}$_slaebz
pure module subroutine stdlib${ii}$_dlaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, d, &
!! DLAEBZ contains the iteration loops which compute and use the
!! function N(w), which is the count of eigenvalues of a symmetric
!! tridiagonal matrix T less than or equal to its argument w. It
!! performs a choice of two types of loops:
!! IJOB=1, followed by
!! IJOB=2: It takes as input a list of intervals and returns a list of
!! sufficiently small intervals whose union contains the same
!! eigenvalues as the union of the original intervals.
!! The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
!! The output interval (AB(j,1),AB(j,2)] will contain
!! eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
!! IJOB=3: It performs a binary search in each input interval
!! (AB(j,1),AB(j,2)] for a point w(j) such that
!! N(w(j))=NVAL(j), and uses C(j) as the starting point of
!! the search. If such a w(j) is found, then on output
!! AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
!! (AB(j,1),AB(j,2)] will be a small interval containing the
!! point where N(w) jumps through NVAL(j), unless that point
!! lies outside the initial interval.
!! Note that the intervals are in all cases half-open intervals,
!! i.e., of the form (a,b] , which includes b but not a .
!! To avoid underflow, the matrix should be scaled so that its largest
!! element is no greater than overflow**(1/2) * underflow**(1/4)
!! in absolute value. To assure the most accurate computation
!! of small eigenvalues, the matrix should be scaled to be
!! not much smaller than that, either.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966
!! Note: the arguments are, in general, *not* checked for unreasonable
!! values.
e, e2, nval, ab, c, mout,nab, work, iwork, info )
! -- lapack auxiliary 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(in) :: ijob, minp, mmax, n, nbmin, nitmax
integer(${ik}$), intent(out) :: info, mout
real(dp), intent(in) :: abstol, pivmin, reltol
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(inout) :: nab(mmax,*), nval(*)
real(dp), intent(inout) :: ab(mmax,*), c(*)
real(dp), intent(in) :: d(*), e(*), e2(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: itmp1, itmp2, j, ji, jit, jp, kf, kfnew, kl, klnew
real(dp) :: tmp1, tmp2
! Intrinsic Functions
! Executable Statements
! check for errors
info = 0_${ik}$
if( ijob<1_${ik}$ .or. ijob>3_${ik}$ ) then
info = -1_${ik}$
return
end if
! initialize nab
if( ijob==1_${ik}$ ) then
! compute the number of eigenvalues in the initial intervals.
mout = 0_${ik}$
do ji = 1, minp
do jp = 1, 2
tmp1 = d( 1_${ik}$ ) - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
nab( ji, jp ) = 0_${ik}$
if( tmp1<=zero )nab( ji, jp ) = 1_${ik}$
do j = 2, n
tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
if( tmp1<=zero )nab( ji, jp ) = nab( ji, jp ) + 1_${ik}$
end do
end do
mout = mout + nab( ji, 2_${ik}$ ) - nab( ji, 1_${ik}$ )
end do
return
end if
! initialize for loop
! kf and kl have the following meaning:
! intervals 1,...,kf-1 have converged.
! intervals kf,...,kl still need to be refined.
kf = 1_${ik}$
kl = minp
! if ijob=2, initialize c.
! if ijob=3, use the user-supplied starting point.
if( ijob==2_${ik}$ ) then
do ji = 1, minp
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
end if
! iteration loop
loop_130: do jit = 1, nitmax
! loop over intervals
if( kl-kf+1>=nbmin .and. nbmin>0_${ik}$ ) then
! begin of parallel version of the loop
do ji = kf, kl
! compute n(c), the number of eigenvalues less than c
work( ji ) = d( 1_${ik}$ ) - c( ji )
iwork( ji ) = 0_${ik}$
if( work( ji )<=pivmin ) then
iwork( ji ) = 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
do j = 2, n
work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji )
if( work( ji )<=pivmin ) then
iwork( ji ) = iwork( ji ) + 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
end do
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
klnew = kl
loop_70: do ji = kf, kl
! insure that n(w) is monotone
iwork( ji ) = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), iwork( ji ) ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( iwork( ji )==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = c( ji )
else if( iwork( ji )==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = c( ji )
else
klnew = klnew + 1_${ik}$
if( klnew<=mmax ) then
! eigenvalue in both intervals -- add upper to
! queue.
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = c( ji )
nab( klnew, 1_${ik}$ ) = iwork( ji )
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
else
info = mmax + 1_${ik}$
end if
end if
end do loop_70
if( info/=0 )return
kl = klnew
else
! ijob=3: binary search. keep only the interval containing
! w s.t. n(w) = nval
do ji = kf, kl
if( iwork( ji )<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = c( ji )
nab( ji, 1_${ik}$ ) = iwork( ji )
end if
if( iwork( ji )>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
end if
end do
end if
else
! end of parallel version of the loop
! begin of serial version of the loop
klnew = kl
loop_100: do ji = kf, kl
! compute n(w), the number of eigenvalues less than w
tmp1 = c( ji )
tmp2 = d( 1_${ik}$ ) - tmp1
itmp1 = 0_${ik}$
if( tmp2<=pivmin ) then
itmp1 = 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
do j = 2, n
tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1
if( tmp2<=pivmin ) then
itmp1 = itmp1 + 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
! insure that n(w) is monotone
itmp1 = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), itmp1 ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( itmp1==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = tmp1
else if( itmp1==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = tmp1
else if( klnew<mmax ) then
! eigenvalue in both intervals -- add upper to queue.
klnew = klnew + 1_${ik}$
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = tmp1
nab( klnew, 1_${ik}$ ) = itmp1
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
else
info = mmax + 1_${ik}$
return
end if
else
! ijob=3: binary search. keep only the interval
! containing w s.t. n(w) = nval
if( itmp1<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = tmp1
nab( ji, 1_${ik}$ ) = itmp1
end if
if( itmp1>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
end if
end if
end do loop_100
kl = klnew
end if
! check for convergence
kfnew = kf
loop_110: do ji = kf, kl
tmp1 = abs( ab( ji, 2_${ik}$ )-ab( ji, 1_${ik}$ ) )
tmp2 = max( abs( ab( ji, 2_${ik}$ ) ), abs( ab( ji, 1_${ik}$ ) ) )
if( tmp1<max( abstol, pivmin, reltol*tmp2 ) .or.nab( ji, 1_${ik}$ )>=nab( ji, 2_${ik}$ ) ) &
then
! converged -- swap with position kfnew,
! then increment kfnew
if( ji>kfnew ) then
tmp1 = ab( ji, 1_${ik}$ )
tmp2 = ab( ji, 2_${ik}$ )
itmp1 = nab( ji, 1_${ik}$ )
itmp2 = nab( ji, 2_${ik}$ )
ab( ji, 1_${ik}$ ) = ab( kfnew, 1_${ik}$ )
ab( ji, 2_${ik}$ ) = ab( kfnew, 2_${ik}$ )
nab( ji, 1_${ik}$ ) = nab( kfnew, 1_${ik}$ )
nab( ji, 2_${ik}$ ) = nab( kfnew, 2_${ik}$ )
ab( kfnew, 1_${ik}$ ) = tmp1
ab( kfnew, 2_${ik}$ ) = tmp2
nab( kfnew, 1_${ik}$ ) = itmp1
nab( kfnew, 2_${ik}$ ) = itmp2
if( ijob==3_${ik}$ ) then
itmp1 = nval( ji )
nval( ji ) = nval( kfnew )
nval( kfnew ) = itmp1
end if
end if
kfnew = kfnew + 1_${ik}$
end if
end do loop_110
kf = kfnew
! choose midpoints
do ji = kf, kl
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
! if no more intervals to refine, quit.
if( kf>kl )go to 140
end do loop_130
! converged
140 continue
info = max( kl+1-kf, 0_${ik}$ )
mout = kl
return
end subroutine stdlib${ii}$_dlaebz
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, d, &
!! DLAEBZ: contains the iteration loops which compute and use the
!! function N(w), which is the count of eigenvalues of a symmetric
!! tridiagonal matrix T less than or equal to its argument w. It
!! performs a choice of two types of loops:
!! IJOB=1, followed by
!! IJOB=2: It takes as input a list of intervals and returns a list of
!! sufficiently small intervals whose union contains the same
!! eigenvalues as the union of the original intervals.
!! The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
!! The output interval (AB(j,1),AB(j,2)] will contain
!! eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
!! IJOB=3: It performs a binary search in each input interval
!! (AB(j,1),AB(j,2)] for a point w(j) such that
!! N(w(j))=NVAL(j), and uses C(j) as the starting point of
!! the search. If such a w(j) is found, then on output
!! AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
!! (AB(j,1),AB(j,2)] will be a small interval containing the
!! point where N(w) jumps through NVAL(j), unless that point
!! lies outside the initial interval.
!! Note that the intervals are in all cases half-open intervals,
!! i.e., of the form (a,b] , which includes b but not a .
!! To avoid underflow, the matrix should be scaled so that its largest
!! element is no greater than overflow**(1/2) * underflow**(1/4)
!! in absolute value. To assure the most accurate computation
!! of small eigenvalues, the matrix should be scaled to be
!! not much smaller than that, either.
!! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
!! Matrix", Report CS41, Computer Science Dept., Stanford
!! University, July 21, 1966
!! Note: the arguments are, in general, *not* checked for unreasonable
!! values.
e, e2, nval, ab, c, mout,nab, work, iwork, info )
! -- lapack auxiliary 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(in) :: ijob, minp, mmax, n, nbmin, nitmax
integer(${ik}$), intent(out) :: info, mout
real(${rk}$), intent(in) :: abstol, pivmin, reltol
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
integer(${ik}$), intent(inout) :: nab(mmax,*), nval(*)
real(${rk}$), intent(inout) :: ab(mmax,*), c(*)
real(${rk}$), intent(in) :: d(*), e(*), e2(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: itmp1, itmp2, j, ji, jit, jp, kf, kfnew, kl, klnew
real(${rk}$) :: tmp1, tmp2
! Intrinsic Functions
! Executable Statements
! check for errors
info = 0_${ik}$
if( ijob<1_${ik}$ .or. ijob>3_${ik}$ ) then
info = -1_${ik}$
return
end if
! initialize nab
if( ijob==1_${ik}$ ) then
! compute the number of eigenvalues in the initial intervals.
mout = 0_${ik}$
do ji = 1, minp
do jp = 1, 2
tmp1 = d( 1_${ik}$ ) - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
nab( ji, jp ) = 0_${ik}$
if( tmp1<=zero )nab( ji, jp ) = 1_${ik}$
do j = 2, n
tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp )
if( abs( tmp1 )<pivmin )tmp1 = -pivmin
if( tmp1<=zero )nab( ji, jp ) = nab( ji, jp ) + 1_${ik}$
end do
end do
mout = mout + nab( ji, 2_${ik}$ ) - nab( ji, 1_${ik}$ )
end do
return
end if
! initialize for loop
! kf and kl have the following meaning:
! intervals 1,...,kf-1 have converged.
! intervals kf,...,kl still need to be refined.
kf = 1_${ik}$
kl = minp
! if ijob=2, initialize c.
! if ijob=3, use the user-supplied starting point.
if( ijob==2_${ik}$ ) then
do ji = 1, minp
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
end if
! iteration loop
loop_130: do jit = 1, nitmax
! loop over intervals
if( kl-kf+1>=nbmin .and. nbmin>0_${ik}$ ) then
! begin of parallel version of the loop
do ji = kf, kl
! compute n(c), the number of eigenvalues less than c
work( ji ) = d( 1_${ik}$ ) - c( ji )
iwork( ji ) = 0_${ik}$
if( work( ji )<=pivmin ) then
iwork( ji ) = 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
do j = 2, n
work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji )
if( work( ji )<=pivmin ) then
iwork( ji ) = iwork( ji ) + 1_${ik}$
work( ji ) = min( work( ji ), -pivmin )
end if
end do
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
klnew = kl
loop_70: do ji = kf, kl
! insure that n(w) is monotone
iwork( ji ) = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), iwork( ji ) ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( iwork( ji )==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = c( ji )
else if( iwork( ji )==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = c( ji )
else
klnew = klnew + 1_${ik}$
if( klnew<=mmax ) then
! eigenvalue in both intervals -- add upper to
! queue.
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = c( ji )
nab( klnew, 1_${ik}$ ) = iwork( ji )
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
else
info = mmax + 1_${ik}$
end if
end if
end do loop_70
if( info/=0 )return
kl = klnew
else
! ijob=3: binary search. keep only the interval containing
! w s.t. n(w) = nval
do ji = kf, kl
if( iwork( ji )<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = c( ji )
nab( ji, 1_${ik}$ ) = iwork( ji )
end if
if( iwork( ji )>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = c( ji )
nab( ji, 2_${ik}$ ) = iwork( ji )
end if
end do
end if
else
! end of parallel version of the loop
! begin of serial version of the loop
klnew = kl
loop_100: do ji = kf, kl
! compute n(w), the number of eigenvalues less than w
tmp1 = c( ji )
tmp2 = d( 1_${ik}$ ) - tmp1
itmp1 = 0_${ik}$
if( tmp2<=pivmin ) then
itmp1 = 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
do j = 2, n
tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1
if( tmp2<=pivmin ) then
itmp1 = itmp1 + 1_${ik}$
tmp2 = min( tmp2, -pivmin )
end if
end do
if( ijob<=2_${ik}$ ) then
! ijob=2: choose all intervals containing eigenvalues.
! insure that n(w) is monotone
itmp1 = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), itmp1 ) )
! update the queue -- add intervals if both halves
! contain eigenvalues.
if( itmp1==nab( ji, 2_${ik}$ ) ) then
! no eigenvalue in the upper interval:
! just use the lower interval.
ab( ji, 2_${ik}$ ) = tmp1
else if( itmp1==nab( ji, 1_${ik}$ ) ) then
! no eigenvalue in the lower interval:
! just use the upper interval.
ab( ji, 1_${ik}$ ) = tmp1
else if( klnew<mmax ) then
! eigenvalue in both intervals -- add upper to queue.
klnew = klnew + 1_${ik}$
ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ )
nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ )
ab( klnew, 1_${ik}$ ) = tmp1
nab( klnew, 1_${ik}$ ) = itmp1
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
else
info = mmax + 1_${ik}$
return
end if
else
! ijob=3: binary search. keep only the interval
! containing w s.t. n(w) = nval
if( itmp1<=nval( ji ) ) then
ab( ji, 1_${ik}$ ) = tmp1
nab( ji, 1_${ik}$ ) = itmp1
end if
if( itmp1>=nval( ji ) ) then
ab( ji, 2_${ik}$ ) = tmp1
nab( ji, 2_${ik}$ ) = itmp1
end if
end if
end do loop_100
kl = klnew
end if
! check for convergence
kfnew = kf
loop_110: do ji = kf, kl
tmp1 = abs( ab( ji, 2_${ik}$ )-ab( ji, 1_${ik}$ ) )
tmp2 = max( abs( ab( ji, 2_${ik}$ ) ), abs( ab( ji, 1_${ik}$ ) ) )
if( tmp1<max( abstol, pivmin, reltol*tmp2 ) .or.nab( ji, 1_${ik}$ )>=nab( ji, 2_${ik}$ ) ) &
then
! converged -- swap with position kfnew,
! then increment kfnew
if( ji>kfnew ) then
tmp1 = ab( ji, 1_${ik}$ )
tmp2 = ab( ji, 2_${ik}$ )
itmp1 = nab( ji, 1_${ik}$ )
itmp2 = nab( ji, 2_${ik}$ )
ab( ji, 1_${ik}$ ) = ab( kfnew, 1_${ik}$ )
ab( ji, 2_${ik}$ ) = ab( kfnew, 2_${ik}$ )
nab( ji, 1_${ik}$ ) = nab( kfnew, 1_${ik}$ )
nab( ji, 2_${ik}$ ) = nab( kfnew, 2_${ik}$ )
ab( kfnew, 1_${ik}$ ) = tmp1
ab( kfnew, 2_${ik}$ ) = tmp2
nab( kfnew, 1_${ik}$ ) = itmp1
nab( kfnew, 2_${ik}$ ) = itmp2
if( ijob==3_${ik}$ ) then
itmp1 = nval( ji )
nval( ji ) = nval( kfnew )
nval( kfnew ) = itmp1
end if
end if
kfnew = kfnew + 1_${ik}$
end if
end do loop_110
kf = kfnew
! choose midpoints
do ji = kf, kl
c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) )
end do
! if no more intervals to refine, quit.
if( kf>kl )go to 140
end do loop_130
! converged
140 continue
info = max( kl+1-kf, 0_${ik}$ )
mout = kl
return
end subroutine stdlib${ii}$_${ri}$laebz
#:endif
#:endfor
pure integer(${ik}$) module function stdlib${ii}$_slaneg( n, d, lld, sigma, pivmin, r )
!! SLANEG computes the Sturm count, the number of negative pivots
!! encountered while factoring tridiagonal T - sigma I = L D L^T.
!! This implementation works directly on the factors without forming
!! the tridiagonal matrix T. The Sturm count is also the number of
!! eigenvalues of T less than sigma.
!! This routine is called from SLARRB.
!! The current routine does not use the PIVMIN parameter but rather
!! requires IEEE-754 propagation of Infinities and NaNs. This
!! routine also has no input range restrictions but does require
!! default exception handling such that x/0 produces Inf when x is
!! non-zero, and Inf/Inf produces NaN. For more information, see:
!! Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
!! Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
!! Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
!! (Tech report version in LAWN 172 with the same title.)
! -- lapack auxiliary 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(in) :: n, r
real(sp), intent(in) :: pivmin, sigma
! Array Arguments
real(sp), intent(in) :: d(*), lld(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: blklen = 128_${ik}$
! some architectures propagate infinities and nans very slowly, so
! the code computes counts in blklen chunks. then a nan can
! propagate at most blklen columns before being detected. this is
! not a general tuning parameter; it needs only to be just large
! enough that the overhead is tiny in common cases.
! Local Scalars
integer(${ik}$) :: bj, j, neg1, neg2, negcnt
real(sp) :: bsav, dminus, dplus, gamma, p, t, tmp
logical(lk) :: sawnan
! Intrinsic Functions
! Executable Statements
negcnt = 0_${ik}$
! i) upper part: l d l^t - sigma i = l+ d+ l+^t
t = -sigma
loop_210: do bj = 1, r-1, blklen
neg1 = 0_${ik}$
bsav = t
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
t = tmp * lld( j ) - sigma
end do
sawnan = stdlib${ii}$_sisnan( t )
! run a slower version of the above loop if a nan is detected.
! a nan should occur only with a zero pivot after an infinite
! pivot. in that case, substituting 1 for t/dplus is the
! correct limit.
if( sawnan ) then
neg1 = 0_${ik}$
t = bsav
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
if (stdlib${ii}$_sisnan(tmp)) tmp = one
t = tmp * lld(j) - sigma
end do
end if
negcnt = negcnt + neg1
end do loop_210
! ii) lower part: l d l^t - sigma i = u- d- u-^t
p = d( n ) - sigma
do bj = n-1, r, -blklen
neg2 = 0_${ik}$
bsav = p
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
p = tmp * d( j ) - sigma
end do
sawnan = stdlib${ii}$_sisnan( p )
! as above, run a slower version that substitutes 1 for inf/inf.
if( sawnan ) then
neg2 = 0_${ik}$
p = bsav
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
if (stdlib${ii}$_sisnan(tmp)) tmp = one
p = tmp * d(j) - sigma
end do
end if
negcnt = negcnt + neg2
end do
! iii) twist index
! t was shifted by sigma initially.
gamma = (t + sigma) + p
if( gamma<zero ) negcnt = negcnt+1
stdlib${ii}$_slaneg = negcnt
end function stdlib${ii}$_slaneg
pure integer(${ik}$) module function stdlib${ii}$_dlaneg( n, d, lld, sigma, pivmin, r )
!! DLANEG computes the Sturm count, the number of negative pivots
!! encountered while factoring tridiagonal T - sigma I = L D L^T.
!! This implementation works directly on the factors without forming
!! the tridiagonal matrix T. The Sturm count is also the number of
!! eigenvalues of T less than sigma.
!! This routine is called from DLARRB.
!! The current routine does not use the PIVMIN parameter but rather
!! requires IEEE-754 propagation of Infinities and NaNs. This
!! routine also has no input range restrictions but does require
!! default exception handling such that x/0 produces Inf when x is
!! non-zero, and Inf/Inf produces NaN. For more information, see:
!! Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
!! Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
!! Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
!! (Tech report version in LAWN 172 with the same title.)
! -- lapack auxiliary 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(in) :: n, r
real(dp), intent(in) :: pivmin, sigma
! Array Arguments
real(dp), intent(in) :: d(*), lld(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: blklen = 128_${ik}$
! some architectures propagate infinities and nans very slowly, so
! the code computes counts in blklen chunks. then a nan can
! propagate at most blklen columns before being detected. this is
! not a general tuning parameter; it needs only to be just large
! enough that the overhead is tiny in common cases.
! Local Scalars
integer(${ik}$) :: bj, j, neg1, neg2, negcnt
real(dp) :: bsav, dminus, dplus, gamma, p, t, tmp
logical(lk) :: sawnan
! Intrinsic Functions
! Executable Statements
negcnt = 0_${ik}$
! i) upper part: l d l^t - sigma i = l+ d+ l+^t
t = -sigma
loop_210: do bj = 1, r-1, blklen
neg1 = 0_${ik}$
bsav = t
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
t = tmp * lld( j ) - sigma
end do
sawnan = stdlib${ii}$_disnan( t )
! run a slower version of the above loop if a nan is detected.
! a nan should occur only with a zero pivot after an infinite
! pivot. in that case, substituting 1 for t/dplus is the
! correct limit.
if( sawnan ) then
neg1 = 0_${ik}$
t = bsav
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
if (stdlib${ii}$_disnan(tmp)) tmp = one
t = tmp * lld(j) - sigma
end do
end if
negcnt = negcnt + neg1
end do loop_210
! ii) lower part: l d l^t - sigma i = u- d- u-^t
p = d( n ) - sigma
do bj = n-1, r, -blklen
neg2 = 0_${ik}$
bsav = p
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
p = tmp * d( j ) - sigma
end do
sawnan = stdlib${ii}$_disnan( p )
! as above, run a slower version that substitutes 1 for inf/inf.
if( sawnan ) then
neg2 = 0_${ik}$
p = bsav
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
if (stdlib${ii}$_disnan(tmp)) tmp = one
p = tmp * d(j) - sigma
end do
end if
negcnt = negcnt + neg2
end do
! iii) twist index
! t was shifted by sigma initially.
gamma = (t + sigma) + p
if( gamma<zero ) negcnt = negcnt+1
stdlib${ii}$_dlaneg = negcnt
end function stdlib${ii}$_dlaneg
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure integer(${ik}$) module function stdlib${ii}$_${ri}$laneg( n, d, lld, sigma, pivmin, r )
!! DLANEG: computes the Sturm count, the number of negative pivots
!! encountered while factoring tridiagonal T - sigma I = L D L^T.
!! This implementation works directly on the factors without forming
!! the tridiagonal matrix T. The Sturm count is also the number of
!! eigenvalues of T less than sigma.
!! This routine is called from DLARRB.
!! The current routine does not use the PIVMIN parameter but rather
!! requires IEEE-754 propagation of Infinities and NaNs. This
!! routine also has no input range restrictions but does require
!! default exception handling such that x/0 produces Inf when x is
!! non-zero, and Inf/Inf produces NaN. For more information, see:
!! Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
!! Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
!! Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
!! (Tech report version in LAWN 172 with the same title.)
! -- lapack auxiliary 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(in) :: n, r
real(${rk}$), intent(in) :: pivmin, sigma
! Array Arguments
real(${rk}$), intent(in) :: d(*), lld(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: blklen = 128_${ik}$
! some architectures propagate infinities and nans very slowly, so
! the code computes counts in blklen chunks. then a nan can
! propagate at most blklen columns before being detected. this is
! not a general tuning parameter; it needs only to be just large
! enough that the overhead is tiny in common cases.
! Local Scalars
integer(${ik}$) :: bj, j, neg1, neg2, negcnt
real(${rk}$) :: bsav, dminus, dplus, gamma, p, t, tmp
logical(lk) :: sawnan
! Intrinsic Functions
! Executable Statements
negcnt = 0_${ik}$
! i) upper part: l d l^t - sigma i = l+ d+ l+^t
t = -sigma
loop_210: do bj = 1, r-1, blklen
neg1 = 0_${ik}$
bsav = t
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
t = tmp * lld( j ) - sigma
end do
sawnan = stdlib${ii}$_${ri}$isnan( t )
! run a slower version of the above loop if a nan is detected.
! a nan should occur only with a zero pivot after an infinite
! pivot. in that case, substituting 1 for t/dplus is the
! correct limit.
if( sawnan ) then
neg1 = 0_${ik}$
t = bsav
do j = bj, min(bj+blklen-1, r-1)
dplus = d( j ) + t
if( dplus<zero ) neg1 = neg1 + 1_${ik}$
tmp = t / dplus
if (stdlib${ii}$_${ri}$isnan(tmp)) tmp = one
t = tmp * lld(j) - sigma
end do
end if
negcnt = negcnt + neg1
end do loop_210
! ii) lower part: l d l^t - sigma i = u- d- u-^t
p = d( n ) - sigma
do bj = n-1, r, -blklen
neg2 = 0_${ik}$
bsav = p
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
p = tmp * d( j ) - sigma
end do
sawnan = stdlib${ii}$_${ri}$isnan( p )
! as above, run a slower version that substitutes 1 for inf/inf.
if( sawnan ) then
neg2 = 0_${ik}$
p = bsav
do j = bj, max(bj-blklen+1, r), -1
dminus = lld( j ) + p
if( dminus<zero ) neg2 = neg2 + 1_${ik}$
tmp = p / dminus
if (stdlib${ii}$_${ri}$isnan(tmp)) tmp = one
p = tmp * d(j) - sigma
end do
end if
negcnt = negcnt + neg2
end do
! iii) twist index
! t was shifted by sigma initially.
gamma = (t + sigma) + p
if( gamma<zero ) negcnt = negcnt+1
stdlib${ii}$_${ri}$laneg = negcnt
end function stdlib${ii}$_${ri}$laneg
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info &
!! SLAED0 computes all eigenvalues and corresponding eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
)
! -- 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(in) :: icompq, ldq, ldqs, n, qsiz
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), e(*), q(ldq,*)
real(sp), intent(out) :: qstore(ldqs,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, &
tlvls
real(sp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>2_${ik}$ ) then
info = -1_${ik}$
else if( ( icompq==1_${ik}$ ) .and. ( qsiz<max( 0_${ik}$, n ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'SLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
if( icompq/=2_${ik}$ ) then
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=sp) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
end if
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
loop_70: do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_ssteqr( 'I', matsiz, d( submat ), e( submat ),q( submat, submat ), &
ldq, work, info )
if( info/=0 )go to 130
else
call stdlib${ii}$_ssteqr( 'I', matsiz, d( submat ), e( submat ),work( iq-1+iwork( &
iqptr+curr ) ), matsiz, work,info )
if( info/=0 )go to 130
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_sgemm( 'N', 'N', qsiz, matsiz, matsiz, one,q( 1_${ik}$, submat ), ldq, &
work( iq-1+iwork( iqptr+curr ) ), matsiz, zero, qstore( 1_${ik}$, submat ),ldqs )
end if
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do loop_70
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
loop_90: do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz.
! stdlib${ii}$_slaed1 is used only for the full eigensystem of a tridiagonal
! matrix.
! stdlib${ii}$_slaed7 handles the cases in which eigenvalues only or eigenvalues
! and eigenvectors of a full symmetric matrix (which was reduced to
! tridiagonal form) are desired.
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_slaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( &
indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info )
else
call stdlib${ii}$_slaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, &
work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), &
iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info )
end if
if( info/=0 )go to 130
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do loop_90
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
if( icompq==1_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_scopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ )
else if( icompq==2_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_scopy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ )
end do
call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ )
call stdlib${ii}$_slacpy( 'A', n, n, work( n+1 ), n, q, ldq )
else
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
end do
call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ )
end if
go to 140
130 continue
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
140 continue
return
end subroutine stdlib${ii}$_slaed0
pure module subroutine stdlib${ii}$_dlaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info &
!! DLAED0 computes all eigenvalues and corresponding eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
)
! -- 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(in) :: icompq, ldq, ldqs, n, qsiz
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), e(*), q(ldq,*)
real(dp), intent(out) :: qstore(ldqs,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, &
tlvls
real(dp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>2_${ik}$ ) then
info = -1_${ik}$
else if( ( icompq==1_${ik}$ ) .and. ( qsiz<max( 0_${ik}$, n ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'DLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
if( icompq/=2_${ik}$ ) then
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=dp) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
end if
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
loop_70: do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_dsteqr( 'I', matsiz, d( submat ), e( submat ),q( submat, submat ), &
ldq, work, info )
if( info/=0 )go to 130
else
call stdlib${ii}$_dsteqr( 'I', matsiz, d( submat ), e( submat ),work( iq-1+iwork( &
iqptr+curr ) ), matsiz, work,info )
if( info/=0 )go to 130
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_dgemm( 'N', 'N', qsiz, matsiz, matsiz, one,q( 1_${ik}$, submat ), ldq, &
work( iq-1+iwork( iqptr+curr ) ), matsiz, zero, qstore( 1_${ik}$, submat ),ldqs )
end if
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do loop_70
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
loop_90: do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz.
! stdlib${ii}$_dlaed1 is used only for the full eigensystem of a tridiagonal
! matrix.
! stdlib${ii}$_dlaed7 handles the cases in which eigenvalues only or eigenvalues
! and eigenvectors of a full symmetric matrix (which was reduced to
! tridiagonal form) are desired.
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_dlaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( &
indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info )
else
call stdlib${ii}$_dlaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, &
work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), &
iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info )
end if
if( info/=0 )go to 130
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do loop_90
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
if( icompq==1_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_dcopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ )
else if( icompq==2_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_dcopy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ )
end do
call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ )
call stdlib${ii}$_dlacpy( 'A', n, n, work( n+1 ), n, q, ldq )
else
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
end do
call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ )
end if
go to 140
130 continue
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
140 continue
return
end subroutine stdlib${ii}$_dlaed0
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info &
!! DLAED0: computes all eigenvalues and corresponding eigenvectors of a
!! symmetric tridiagonal matrix using the divide and conquer method.
)
! -- 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(in) :: icompq, ldq, ldqs, n, qsiz
integer(${ik}$), intent(out) :: info
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: d(*), e(*), q(ldq,*)
real(${rk}$), intent(out) :: qstore(ldqs,*), work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, &
tlvls
real(${rk}$) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>2_${ik}$ ) then
info = -1_${ik}$
else if( ( icompq==1_${ik}$ ) .and. ( qsiz<max( 0_${ik}$, n ) ) ) then
info = -2_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'DLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
if( icompq/=2_${ik}$ ) then
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=${rk}$) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
end if
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
loop_70: do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_${ri}$steqr( 'I', matsiz, d( submat ), e( submat ),q( submat, submat ), &
ldq, work, info )
if( info/=0 )go to 130
else
call stdlib${ii}$_${ri}$steqr( 'I', matsiz, d( submat ), e( submat ),work( iq-1+iwork( &
iqptr+curr ) ), matsiz, work,info )
if( info/=0 )go to 130
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', qsiz, matsiz, matsiz, one,q( 1_${ik}$, submat ), ldq, &
work( iq-1+iwork( iqptr+curr ) ), matsiz, zero, qstore( 1_${ik}$, submat ),ldqs )
end if
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do loop_70
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
loop_90: do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz.
! stdlib${ii}$_${ri}$laed1 is used only for the full eigensystem of a tridiagonal
! matrix.
! stdlib${ii}$_${ri}$laed7 handles the cases in which eigenvalues only or eigenvalues
! and eigenvectors of a full symmetric matrix (which was reduced to
! tridiagonal form) are desired.
if( icompq==2_${ik}$ ) then
call stdlib${ii}$_${ri}$laed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( &
indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info )
else
call stdlib${ii}$_${ri}$laed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, &
work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), &
iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info )
end if
if( info/=0 )go to 130
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do loop_90
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
if( icompq==1_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_${ri}$copy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ )
else if( icompq==2_${ik}$ ) then
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
call stdlib${ii}$_${ri}$copy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ )
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, work( n+1 ), n, q, ldq )
else
do i = 1, n
j = iwork( indxq+i )
work( i ) = d( j )
end do
call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ )
end if
go to 140
130 continue
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
140 continue
return
end subroutine stdlib${ii}$_${ri}$laed0
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info )
!! Using the divide and conquer method, CLAED0: computes all eigenvalues
!! of a symmetric tridiagonal matrix which is one diagonal block of
!! those from reducing a dense or band Hermitian matrix and
!! corresponding eigenvectors of the dense or band matrix.
! -- 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) :: ldq, ldqs, n, qsiz
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), e(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: q(ldq,*)
complex(sp), intent(out) :: qstore(ldqs,*)
! =====================================================================
! warning: n could be as big as qsiz!
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, &
subpbs, tlvls
real(sp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq < 0 .or. icompq > 2 ) then
! info = -1
! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) )
! $ then
if( qsiz<max( 0_${ik}$, n ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'CLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=sp) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
ll = iq - 1_${ik}$ + iwork( iqptr+curr )
call stdlib${ii}$_ssteqr( 'I', matsiz, d( submat ), e( submat ),rwork( ll ), matsiz, &
rwork, info )
call stdlib${ii}$_clacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( &
1_${ik}$, submat ), ldqs,rwork( iwrem ) )
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz. stdlib${ii}$_claed7 handles the case
! when the eigenvectors of a full or band hermitian matrix (which
! was reduced to tridiagonal form) are desired.
! i am free to use q as a valuable working space until loop 150.
call stdlib${ii}$_claed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), &
iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), &
rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info )
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
do i = 1, n
j = iwork( indxq+i )
rwork( i ) = d( j )
call stdlib${ii}$_ccopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_scopy( n, rwork, 1_${ik}$, d, 1_${ik}$ )
return
end subroutine stdlib${ii}$_claed0
pure module subroutine stdlib${ii}$_zlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info )
!! Using the divide and conquer method, ZLAED0: computes all eigenvalues
!! of a symmetric tridiagonal matrix which is one diagonal block of
!! those from reducing a dense or band Hermitian matrix and
!! corresponding eigenvectors of the dense or band matrix.
! -- 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) :: ldq, ldqs, n, qsiz
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), e(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: q(ldq,*)
complex(dp), intent(out) :: qstore(ldqs,*)
! =====================================================================
! warning: n could be as big as qsiz!
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, &
subpbs, tlvls
real(dp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq < 0 .or. icompq > 2 ) then
! info = -1
! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) )
! $ then
if( qsiz<max( 0_${ik}$, n ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=dp) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
ll = iq - 1_${ik}$ + iwork( iqptr+curr )
call stdlib${ii}$_dsteqr( 'I', matsiz, d( submat ), e( submat ),rwork( ll ), matsiz, &
rwork, info )
call stdlib${ii}$_zlacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( &
1_${ik}$, submat ), ldqs,rwork( iwrem ) )
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz. stdlib${ii}$_zlaed7 handles the case
! when the eigenvectors of a full or band hermitian matrix (which
! was reduced to tridiagonal form) are desired.
! i am free to use q as a valuable working space until loop 150.
call stdlib${ii}$_zlaed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), &
iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), &
rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info )
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
do i = 1, n
j = iwork( indxq+i )
rwork( i ) = d( j )
call stdlib${ii}$_zcopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_dcopy( n, rwork, 1_${ik}$, d, 1_${ik}$ )
return
end subroutine stdlib${ii}$_zlaed0
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info )
!! Using the divide and conquer method, ZLAED0: computes all eigenvalues
!! of a symmetric tridiagonal matrix which is one diagonal block of
!! those from reducing a dense or band Hermitian matrix and
!! corresponding eigenvectors of the dense or band matrix.
! -- 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) :: ldq, ldqs, n, qsiz
! Array Arguments
integer(${ik}$), intent(out) :: iwork(*)
real(${ck}$), intent(inout) :: d(*), e(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: q(ldq,*)
complex(${ck}$), intent(out) :: qstore(ldqs,*)
! =====================================================================
! warning: n could be as big as qsiz!
! Local Scalars
integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, &
iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, &
subpbs, tlvls
real(${ck}$) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq < 0 .or. icompq > 2 ) then
! info = -1
! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) )
! $ then
if( qsiz<max( 0_${ik}$, n ) ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( ldqs<max( 1_${ik}$, n ) ) then
info = -8_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED0', -info )
return
end if
! quick return if possible
if( n==0 )return
smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZLAED0', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ )
! determine the size and placement of the submatrices, and save in
! the leading elements of iwork.
iwork( 1_${ik}$ ) = n
subpbs = 1_${ik}$
tlvls = 0_${ik}$
10 continue
if( iwork( subpbs )>smlsiz ) then
do j = subpbs, 1, -1
iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$
iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$
end do
tlvls = tlvls + 1_${ik}$
subpbs = 2_${ik}$*subpbs
go to 10
end if
do j = 2, subpbs
iwork( j ) = iwork( j ) + iwork( j-1 )
end do
! divide the matrix into subpbs submatrices of size at most smlsiz+1
! using rank-1 modifications (cuts).
spm1 = subpbs - 1_${ik}$
do i = 1, spm1
submat = iwork( i ) + 1_${ik}$
smm1 = submat - 1_${ik}$
d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
d( submat ) = d( submat ) - abs( e( smm1 ) )
end do
indxq = 4_${ik}$*n + 3_${ik}$
! set up workspaces for eigenvalues only/accumulate new vectors
! routine
temp = log( real( n,KIND=${ck}$) ) / log( two )
lgn = int( temp,KIND=${ik}$)
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
if( 2_${ik}$**lgn<n )lgn = lgn + 1_${ik}$
iprmpt = indxq + n + 1_${ik}$
iperm = iprmpt + n*lgn
iqptr = iperm + n*lgn
igivpt = iqptr + n + 2_${ik}$
igivcl = igivpt + n*lgn
igivnm = 1_${ik}$
iq = igivnm + 2_${ik}$*n*lgn
iwrem = iq + n**2_${ik}$ + 1_${ik}$
! initialize pointers
do i = 0, subpbs
iwork( iprmpt+i ) = 1_${ik}$
iwork( igivpt+i ) = 1_${ik}$
end do
iwork( iqptr ) = 1_${ik}$
! solve each submatrix eigenproblem at the bottom of the divide and
! conquer tree.
curr = 0_${ik}$
do i = 0, spm1
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 1_${ik}$ )
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+1 ) - iwork( i )
end if
ll = iq - 1_${ik}$ + iwork( iqptr+curr )
call stdlib${ii}$_${c2ri(ci)}$steqr( 'I', matsiz, d( submat ), e( submat ),rwork( ll ), matsiz, &
rwork, info )
call stdlib${ii}$_${ci}$lacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( &
1_${ik}$, submat ), ldqs,rwork( iwrem ) )
iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$
curr = curr + 1_${ik}$
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
k = 1_${ik}$
do j = submat, iwork( i+1 )
iwork( indxq+j ) = k
k = k + 1_${ik}$
end do
end do
! successively merge eigensystems of adjacent submatrices
! into eigensystem for the corresponding larger matrix.
! while ( subpbs > 1 )
curlvl = 1_${ik}$
80 continue
if( subpbs>1_${ik}$ ) then
spm2 = subpbs - 2_${ik}$
do i = 0, spm2, 2
if( i==0_${ik}$ ) then
submat = 1_${ik}$
matsiz = iwork( 2_${ik}$ )
msd2 = iwork( 1_${ik}$ )
curprb = 0_${ik}$
else
submat = iwork( i ) + 1_${ik}$
matsiz = iwork( i+2 ) - iwork( i )
msd2 = matsiz / 2_${ik}$
curprb = curprb + 1_${ik}$
end if
! merge lower order eigensystems (of size msd2 and matsiz - msd2)
! into an eigensystem of size matsiz. stdlib${ii}$_${ci}$laed7 handles the case
! when the eigenvectors of a full or band hermitian matrix (which
! was reduced to tridiagonal form) are desired.
! i am free to use q as a valuable working space until loop 150.
call stdlib${ii}$_${ci}$laed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), &
qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), &
iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), &
rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info )
if( info>0_${ik}$ ) then
info = submat*( n+1 ) + submat + matsiz - 1_${ik}$
return
end if
iwork( i / 2_${ik}$+1 ) = iwork( i+2 )
end do
subpbs = subpbs / 2_${ik}$
curlvl = curlvl + 1_${ik}$
go to 80
end if
! end while
! re-merge the eigenvalues/vectors which were deflated at the final
! merge step.
do i = 1, n
j = iwork( indxq+i )
rwork( i ) = d( j )
call stdlib${ii}$_${ci}$copy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ )
end do
call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork, 1_${ik}$, d, 1_${ik}$ )
return
end subroutine stdlib${ii}$_${ci}$laed0
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info )
!! SLAED1 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles
!! the case in which eigenvalues only or eigenvalues and eigenvectors
!! of a full symmetric matrix (which was reduced to tridiagonal form)
!! are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**T*u, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine SLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine SLAED4 (as called by SLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
! -- 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(in) :: cutpnt, ldq, n
integer(${ik}$), intent(out) :: info
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: indxq(*)
integer(${ik}$), intent(out) :: iwork(*)
real(sp), intent(inout) :: d(*), q(ldq,*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, cpp1, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, &
n2
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( min( 1_${ik}$, n / 2_${ik}$ )>cutpnt .or. ( n / 2_${ik}$ )<cutpnt ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED1', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are integer pointers which indicate
! the portion of the workspace
! used by a particular array in stdlib${ii}$_slaed2 and stdlib${ii}$_slaed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
call stdlib${ii}$_scopy( cutpnt, q( cutpnt, 1_${ik}$ ), ldq, work( iz ), 1_${ik}$ )
cpp1 = cutpnt + 1_${ik}$
call stdlib${ii}$_scopy( n-cutpnt, q( cpp1, cpp1 ), ldq, work( iz+cutpnt ), 1_${ik}$ )
! deflate eigenvalues.
call stdlib${ii}$_slaed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ),work( idlmda ), &
work( iw ), work( iq2 ),iwork( indx ), iwork( indxc ), iwork( indxp ),iwork( coltyp ), &
info )
if( info/=0 )go to 20
! solve secular equation.
if( k/=0_${ik}$ ) then
is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt +( iwork( coltyp+1 )+iwork( &
coltyp+2 ) )*( n-cutpnt ) + iq2
call stdlib${ii}$_slaed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ),work( iq2 ), iwork(&
indxc ), iwork( coltyp ),work( iw ), work( is ), info )
if( info/=0 )go to 20
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_slamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
do i = 1, n
indxq( i ) = i
end do
end if
20 continue
return
end subroutine stdlib${ii}$_slaed1
pure module subroutine stdlib${ii}$_dlaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info )
!! DLAED1 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
!! the case in which eigenvalues only or eigenvalues and eigenvectors
!! of a full symmetric matrix (which was reduced to tridiagonal form)
!! are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**T*u, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by DLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
! -- 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(in) :: cutpnt, ldq, n
integer(${ik}$), intent(out) :: info
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: indxq(*)
integer(${ik}$), intent(out) :: iwork(*)
real(dp), intent(inout) :: d(*), q(ldq,*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, &
zpp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( min( 1_${ik}$, n / 2_${ik}$ )>cutpnt .or. ( n / 2_${ik}$ )<cutpnt ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED1', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are integer pointers which indicate
! the portion of the workspace
! used by a particular array in stdlib${ii}$_dlaed2 and stdlib${ii}$_dlaed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
call stdlib${ii}$_dcopy( cutpnt, q( cutpnt, 1_${ik}$ ), ldq, work( iz ), 1_${ik}$ )
zpp1 = cutpnt + 1_${ik}$
call stdlib${ii}$_dcopy( n-cutpnt, q( zpp1, zpp1 ), ldq, work( iz+cutpnt ), 1_${ik}$ )
! deflate eigenvalues.
call stdlib${ii}$_dlaed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ),work( idlmda ), &
work( iw ), work( iq2 ),iwork( indx ), iwork( indxc ), iwork( indxp ),iwork( coltyp ), &
info )
if( info/=0 )go to 20
! solve secular equation.
if( k/=0_${ik}$ ) then
is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt +( iwork( coltyp+1 )+iwork( &
coltyp+2 ) )*( n-cutpnt ) + iq2
call stdlib${ii}$_dlaed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ),work( iq2 ), iwork(&
indxc ), iwork( coltyp ),work( iw ), work( is ), info )
if( info/=0 )go to 20
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_dlamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
do i = 1, n
indxq( i ) = i
end do
end if
20 continue
return
end subroutine stdlib${ii}$_dlaed1
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info )
!! DLAED1: computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
!! the case in which eigenvalues only or eigenvalues and eigenvectors
!! of a full symmetric matrix (which was reduced to tridiagonal form)
!! are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**T*u, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by DLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
! -- 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(in) :: cutpnt, ldq, n
integer(${ik}$), intent(out) :: info
real(${rk}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: indxq(*)
integer(${ik}$), intent(out) :: iwork(*)
real(${rk}$), intent(inout) :: d(*), q(ldq,*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, &
zpp1
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -4_${ik}$
else if( min( 1_${ik}$, n / 2_${ik}$ )>cutpnt .or. ( n / 2_${ik}$ )<cutpnt ) then
info = -7_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED1', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are integer pointers which indicate
! the portion of the workspace
! used by a particular array in stdlib${ii}$_${ri}$laed2 and stdlib${ii}$_${ri}$laed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
call stdlib${ii}$_${ri}$copy( cutpnt, q( cutpnt, 1_${ik}$ ), ldq, work( iz ), 1_${ik}$ )
zpp1 = cutpnt + 1_${ik}$
call stdlib${ii}$_${ri}$copy( n-cutpnt, q( zpp1, zpp1 ), ldq, work( iz+cutpnt ), 1_${ik}$ )
! deflate eigenvalues.
call stdlib${ii}$_${ri}$laed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ),work( idlmda ), &
work( iw ), work( iq2 ),iwork( indx ), iwork( indxc ), iwork( indxp ),iwork( coltyp ), &
info )
if( info/=0 )go to 20
! solve secular equation.
if( k/=0_${ik}$ ) then
is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt +( iwork( coltyp+1 )+iwork( &
coltyp+2 ) )*( n-cutpnt ) + iq2
call stdlib${ii}$_${ri}$laed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ),work( iq2 ), iwork(&
indxc ), iwork( coltyp ),work( iw ), work( is ), info )
if( info/=0 )go to 20
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_${ri}$lamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
do i = 1, n
indxq( i ) = i
end do
end if
20 continue
return
end subroutine stdlib${ii}$_${ri}$laed1
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed2( k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w,q2, indx, indxc,&
!! SLAED2 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny entry in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, coltyp, 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, k
integer(${ik}$), intent(in) :: ldq, n, n1
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: coltyp(*), indx(*), indxc(*), indxp(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(sp), intent(inout) :: d(*), q(ldq,*), z(*)
real(sp), intent(out) :: dlamda(*), q2(*), w(*)
! =====================================================================
! Parameters
real(sp), parameter :: mone = -1.0_sp
! Local Arrays
integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$)
! Local Scalars
integer(${ik}$) :: ct, i, imax, iq1, iq2, j, jmax, js, k2, n1p1, n2, nj, pj
real(sp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( min( 1_${ik}$, ( n / 2_${ik}$ ) )>n1 .or. ( n / 2_${ik}$ )<n1 ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED2', -info )
return
end if
! quick return if possible
if( n==0 )return
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_sscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1. since z is the concatenation of
! two normalized vectors, norm2(z) = sqrt(2).
t = one / sqrt( two )
call stdlib${ii}$_sscal( n, t, z, 1_${ik}$ )
! rho = abs( norm(z)**2 * rho )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = n1p1, n
indxq( i ) = indxq( i ) + n1
end do
! re-integrate the deflated parts from the last pass
do i = 1, n
dlamda( i ) = d( indxq( i ) )
end do
call stdlib${ii}$_slamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indxc )
do i = 1, n
indx( i ) = indxq( indxc( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_isamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_isamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_slamch( 'EPSILON' )
tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
iq2 = 1_${ik}$
do j = 1, n
i = indx( j )
call stdlib${ii}$_scopy( n, q( 1_${ik}$, i ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
dlamda( j ) = d( i )
iq2 = iq2 + n
end do
call stdlib${ii}$_slacpy( 'A', n, n, q2, n, q, ldq )
call stdlib${ii}$_scopy( n, dlamda, 1_${ik}$, d, 1_${ik}$ )
go to 190
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
do i = 1, n1
coltyp( i ) = 1_${ik}$
end do
do i = n1p1, n
coltyp( i ) = 3_${ik}$
end do
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
nj = indx( j )
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
if( j==n )go to 100
else
pj = nj
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
nj = indx( j )
if( j>n )go to 100
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
else
! check if eigenvalues are close enough to allow deflation.
s = z( pj )
c = z( nj )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_slapy2( c, s )
t = d( nj ) - d( pj )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( nj ) = tau
z( pj ) = zero
if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$
coltyp( pj ) = 4_${ik}$
call stdlib${ii}$_srot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s )
t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$
d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$
d( pj ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( pj )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = pj
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = pj
end if
else
indxp( k2+i-1 ) = pj
end if
pj = nj
else
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
pj = nj
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
! count up the total number of the various types of columns, then
! form a permutation which positions the four column types into
! four uniform groups (although one or more of these groups may be
! empty).
do j = 1, 4
ctot( j ) = 0_${ik}$
end do
do j = 1, n
ct = coltyp( j )
ctot( ct ) = ctot( ct ) + 1_${ik}$
end do
! psm(*) = position in submatrix (of types 1 through 4)
psm( 1_${ik}$ ) = 1_${ik}$
psm( 2_${ik}$ ) = 1_${ik}$ + ctot( 1_${ik}$ )
psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ )
psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ )
k = n - ctot( 4_${ik}$ )
! fill out the indxc array so that the permutation which it induces
! will place all type-1 columns first, all type-2 columns next,
! then all type-3's, and finally all type-4's.
do j = 1, n
js = indxp( j )
ct = coltyp( js )
indx( psm( ct ) ) = js
indxc( psm( ct ) ) = j
psm( ct ) = psm( ct ) + 1_${ik}$
end do
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
i = 1_${ik}$
iq1 = 1_${ik}$
iq2 = 1_${ik}$ + ( ctot( 1_${ik}$ )+ctot( 2_${ik}$ ) )*n1
do j = 1, ctot( 1 )
js = indx( i )
call stdlib${ii}$_scopy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
end do
do j = 1, ctot( 2 )
js = indx( i )
call stdlib${ii}$_scopy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
call stdlib${ii}$_scopy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
iq2 = iq2 + n2
end do
do j = 1, ctot( 3 )
js = indx( i )
call stdlib${ii}$_scopy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq2 = iq2 + n2
end do
iq1 = iq2
do j = 1, ctot( 4 )
js = indx( i )
call stdlib${ii}$_scopy( n, q( 1_${ik}$, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
iq2 = iq2 + n
z( i ) = d( js )
i = i + 1_${ik}$
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_slacpy( 'A', n, ctot( 4_${ik}$ ), q2( iq1 ), n,q( 1_${ik}$, k+1 ), ldq )
call stdlib${ii}$_scopy( n-k, z( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
end if
! copy ctot into coltyp for referencing in stdlib${ii}$_slaed3.
do j = 1, 4
coltyp( j ) = ctot( j )
end do
190 continue
return
end subroutine stdlib${ii}$_slaed2
pure module subroutine stdlib${ii}$_dlaed2( k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w,q2, indx, indxc,&
!! DLAED2 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny entry in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, coltyp, 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, k
integer(${ik}$), intent(in) :: ldq, n, n1
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: coltyp(*), indx(*), indxc(*), indxp(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(dp), intent(inout) :: d(*), q(ldq,*), z(*)
real(dp), intent(out) :: dlamda(*), q2(*), w(*)
! =====================================================================
! Parameters
real(dp), parameter :: mone = -1.0_dp
! Local Arrays
integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$)
! Local Scalars
integer(${ik}$) :: ct, i, imax, iq1, iq2, j, jmax, js, k2, n1p1, n2, nj, pj
real(dp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( min( 1_${ik}$, ( n / 2_${ik}$ ) )>n1 .or. ( n / 2_${ik}$ )<n1 ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED2', -info )
return
end if
! quick return if possible
if( n==0 )return
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_dscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1. since z is the concatenation of
! two normalized vectors, norm2(z) = sqrt(2).
t = one / sqrt( two )
call stdlib${ii}$_dscal( n, t, z, 1_${ik}$ )
! rho = abs( norm(z)**2 * rho )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = n1p1, n
indxq( i ) = indxq( i ) + n1
end do
! re-integrate the deflated parts from the last pass
do i = 1, n
dlamda( i ) = d( indxq( i ) )
end do
call stdlib${ii}$_dlamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indxc )
do i = 1, n
indx( i ) = indxq( indxc( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_idamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_idamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
iq2 = 1_${ik}$
do j = 1, n
i = indx( j )
call stdlib${ii}$_dcopy( n, q( 1_${ik}$, i ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
dlamda( j ) = d( i )
iq2 = iq2 + n
end do
call stdlib${ii}$_dlacpy( 'A', n, n, q2, n, q, ldq )
call stdlib${ii}$_dcopy( n, dlamda, 1_${ik}$, d, 1_${ik}$ )
go to 190
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
do i = 1, n1
coltyp( i ) = 1_${ik}$
end do
do i = n1p1, n
coltyp( i ) = 3_${ik}$
end do
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
nj = indx( j )
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
if( j==n )go to 100
else
pj = nj
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
nj = indx( j )
if( j>n )go to 100
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
else
! check if eigenvalues are close enough to allow deflation.
s = z( pj )
c = z( nj )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_dlapy2( c, s )
t = d( nj ) - d( pj )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( nj ) = tau
z( pj ) = zero
if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$
coltyp( pj ) = 4_${ik}$
call stdlib${ii}$_drot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s )
t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$
d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$
d( pj ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( pj )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = pj
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = pj
end if
else
indxp( k2+i-1 ) = pj
end if
pj = nj
else
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
pj = nj
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
! count up the total number of the various types of columns, then
! form a permutation which positions the four column types into
! four uniform groups (although one or more of these groups may be
! empty).
do j = 1, 4
ctot( j ) = 0_${ik}$
end do
do j = 1, n
ct = coltyp( j )
ctot( ct ) = ctot( ct ) + 1_${ik}$
end do
! psm(*) = position in submatrix (of types 1 through 4)
psm( 1_${ik}$ ) = 1_${ik}$
psm( 2_${ik}$ ) = 1_${ik}$ + ctot( 1_${ik}$ )
psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ )
psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ )
k = n - ctot( 4_${ik}$ )
! fill out the indxc array so that the permutation which it induces
! will place all type-1 columns first, all type-2 columns next,
! then all type-3's, and finally all type-4's.
do j = 1, n
js = indxp( j )
ct = coltyp( js )
indx( psm( ct ) ) = js
indxc( psm( ct ) ) = j
psm( ct ) = psm( ct ) + 1_${ik}$
end do
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
i = 1_${ik}$
iq1 = 1_${ik}$
iq2 = 1_${ik}$ + ( ctot( 1_${ik}$ )+ctot( 2_${ik}$ ) )*n1
do j = 1, ctot( 1 )
js = indx( i )
call stdlib${ii}$_dcopy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
end do
do j = 1, ctot( 2 )
js = indx( i )
call stdlib${ii}$_dcopy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
call stdlib${ii}$_dcopy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
iq2 = iq2 + n2
end do
do j = 1, ctot( 3 )
js = indx( i )
call stdlib${ii}$_dcopy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq2 = iq2 + n2
end do
iq1 = iq2
do j = 1, ctot( 4 )
js = indx( i )
call stdlib${ii}$_dcopy( n, q( 1_${ik}$, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
iq2 = iq2 + n
z( i ) = d( js )
i = i + 1_${ik}$
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_dlacpy( 'A', n, ctot( 4_${ik}$ ), q2( iq1 ), n,q( 1_${ik}$, k+1 ), ldq )
call stdlib${ii}$_dcopy( n-k, z( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
end if
! copy ctot into coltyp for referencing in stdlib${ii}$_dlaed3.
do j = 1, 4
coltyp( j ) = ctot( j )
end do
190 continue
return
end subroutine stdlib${ii}$_dlaed2
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed2( k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w,q2, indx, indxc,&
!! DLAED2: merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny entry in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, coltyp, 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, k
integer(${ik}$), intent(in) :: ldq, n, n1
real(${rk}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: coltyp(*), indx(*), indxc(*), indxp(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(${rk}$), intent(inout) :: d(*), q(ldq,*), z(*)
real(${rk}$), intent(out) :: dlamda(*), q2(*), w(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: mone = -1.0_${rk}$
! Local Arrays
integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$)
! Local Scalars
integer(${ik}$) :: ct, i, imax, iq1, iq2, j, jmax, js, k2, n1p1, n2, nj, pj
real(${rk}$) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
else if( min( 1_${ik}$, ( n / 2_${ik}$ ) )>n1 .or. ( n / 2_${ik}$ )<n1 ) then
info = -3_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED2', -info )
return
end if
! quick return if possible
if( n==0 )return
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_${ri}$scal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1. since z is the concatenation of
! two normalized vectors, norm2(z) = sqrt(2).
t = one / sqrt( two )
call stdlib${ii}$_${ri}$scal( n, t, z, 1_${ik}$ )
! rho = abs( norm(z)**2 * rho )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = n1p1, n
indxq( i ) = indxq( i ) + n1
end do
! re-integrate the deflated parts from the last pass
do i = 1, n
dlamda( i ) = d( indxq( i ) )
end do
call stdlib${ii}$_${ri}$lamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indxc )
do i = 1, n
indx( i ) = indxq( indxc( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_i${ri}$amax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_i${ri}$amax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
iq2 = 1_${ik}$
do j = 1, n
i = indx( j )
call stdlib${ii}$_${ri}$copy( n, q( 1_${ik}$, i ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
dlamda( j ) = d( i )
iq2 = iq2 + n
end do
call stdlib${ii}$_${ri}$lacpy( 'A', n, n, q2, n, q, ldq )
call stdlib${ii}$_${ri}$copy( n, dlamda, 1_${ik}$, d, 1_${ik}$ )
go to 190
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
do i = 1, n1
coltyp( i ) = 1_${ik}$
end do
do i = n1p1, n
coltyp( i ) = 3_${ik}$
end do
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
nj = indx( j )
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
if( j==n )go to 100
else
pj = nj
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
nj = indx( j )
if( j>n )go to 100
if( rho*abs( z( nj ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
coltyp( nj ) = 4_${ik}$
indxp( k2 ) = nj
else
! check if eigenvalues are close enough to allow deflation.
s = z( pj )
c = z( nj )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_${ri}$lapy2( c, s )
t = d( nj ) - d( pj )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( nj ) = tau
z( pj ) = zero
if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$
coltyp( pj ) = 4_${ik}$
call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s )
t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$
d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$
d( pj ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( pj )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = pj
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = pj
end if
else
indxp( k2+i-1 ) = pj
end if
pj = nj
else
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
pj = nj
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
dlamda( k ) = d( pj )
w( k ) = z( pj )
indxp( k ) = pj
! count up the total number of the various types of columns, then
! form a permutation which positions the four column types into
! four uniform groups (although one or more of these groups may be
! empty).
do j = 1, 4
ctot( j ) = 0_${ik}$
end do
do j = 1, n
ct = coltyp( j )
ctot( ct ) = ctot( ct ) + 1_${ik}$
end do
! psm(*) = position in submatrix (of types 1 through 4)
psm( 1_${ik}$ ) = 1_${ik}$
psm( 2_${ik}$ ) = 1_${ik}$ + ctot( 1_${ik}$ )
psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ )
psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ )
k = n - ctot( 4_${ik}$ )
! fill out the indxc array so that the permutation which it induces
! will place all type-1 columns first, all type-2 columns next,
! then all type-3's, and finally all type-4's.
do j = 1, n
js = indxp( j )
ct = coltyp( js )
indx( psm( ct ) ) = js
indxc( psm( ct ) ) = j
psm( ct ) = psm( ct ) + 1_${ik}$
end do
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
i = 1_${ik}$
iq1 = 1_${ik}$
iq2 = 1_${ik}$ + ( ctot( 1_${ik}$ )+ctot( 2_${ik}$ ) )*n1
do j = 1, ctot( 1 )
js = indx( i )
call stdlib${ii}$_${ri}$copy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
end do
do j = 1, ctot( 2 )
js = indx( i )
call stdlib${ii}$_${ri}$copy( n1, q( 1_${ik}$, js ), 1_${ik}$, q2( iq1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$copy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq1 = iq1 + n1
iq2 = iq2 + n2
end do
do j = 1, ctot( 3 )
js = indx( i )
call stdlib${ii}$_${ri}$copy( n2, q( n1+1, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
z( i ) = d( js )
i = i + 1_${ik}$
iq2 = iq2 + n2
end do
iq1 = iq2
do j = 1, ctot( 4 )
js = indx( i )
call stdlib${ii}$_${ri}$copy( n, q( 1_${ik}$, js ), 1_${ik}$, q2( iq2 ), 1_${ik}$ )
iq2 = iq2 + n
z( i ) = d( js )
i = i + 1_${ik}$
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_${ri}$lacpy( 'A', n, ctot( 4_${ik}$ ), q2( iq1 ), n,q( 1_${ik}$, k+1 ), ldq )
call stdlib${ii}$_${ri}$copy( n-k, z( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
end if
! copy ctot into coltyp for referencing in stdlib${ii}$_${ri}$laed3.
do j = 1, 4
coltyp( j ) = ctot( j )
end do
190 continue
return
end subroutine stdlib${ii}$_${ri}$laed2
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info )
!! SLAED3 finds the roots of the secular equation, as defined by the
!! values in D, W, and RHO, between 1 and K. It makes the
!! appropriate calls to SLAED4 and then updates the eigenvectors by
!! multiplying the matrix of eigenvectors of the pair of eigensystems
!! being combined by the matrix of eigenvectors of the K-by-K system
!! which is solved here.
!! 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.
! -- 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) :: k, ldq, n, n1
real(sp), intent(in) :: rho
! Array Arguments
integer(${ik}$), intent(in) :: ctot(*), indx(*)
real(sp), intent(out) :: d(*), q(ldq,*), s(*)
real(sp), intent(inout) :: dlamda(*), w(*)
real(sp), intent(in) :: q2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, iq2, j, n12, n2, n23
real(sp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( n<k ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED3', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, k
dlamda( i ) = stdlib${ii}$_slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = 1, k
call stdlib${ii}$_slaed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1 )go to 110
if( k==2_${ik}$ ) then
do j = 1, k
w( 1_${ik}$ ) = q( 1_${ik}$, j )
w( 2_${ik}$ ) = q( 2_${ik}$, j )
ii = indx( 1_${ik}$ )
q( 1_${ik}$, j ) = w( ii )
ii = indx( 2_${ik}$ )
q( 2_${ik}$, j ) = w( ii )
end do
go to 110
end if
! compute updated w.
call stdlib${ii}$_scopy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_scopy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
s( i ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_snrm2( k, s, 1_${ik}$ )
do i = 1, k
ii = indx( i )
q( i, j ) = s( ii ) / temp
end do
end do
! compute the updated eigenvectors.
110 continue
n2 = n - n1
n12 = ctot( 1_${ik}$ ) + ctot( 2_${ik}$ )
n23 = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ )
call stdlib${ii}$_slacpy( 'A', n23, k, q( ctot( 1_${ik}$ )+1_${ik}$, 1_${ik}$ ), ldq, s, n23 )
iq2 = n1*n12 + 1_${ik}$
if( n23/=0_${ik}$ ) then
call stdlib${ii}$_sgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,zero, q( n1+1, &
1_${ik}$ ), ldq )
else
call stdlib${ii}$_slaset( 'A', n2, k, zero, zero, q( n1+1, 1_${ik}$ ), ldq )
end if
call stdlib${ii}$_slacpy( 'A', n12, k, q, ldq, s, n12 )
if( n12/=0_${ik}$ ) then
call stdlib${ii}$_sgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,ldq )
else
call stdlib${ii}$_slaset( 'A', n1, k, zero, zero, q( 1_${ik}$, 1_${ik}$ ), ldq )
end if
120 continue
return
end subroutine stdlib${ii}$_slaed3
pure module subroutine stdlib${ii}$_dlaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info )
!! DLAED3 finds the roots of the secular equation, as defined by the
!! values in D, W, and RHO, between 1 and K. It makes the
!! appropriate calls to DLAED4 and then updates the eigenvectors by
!! multiplying the matrix of eigenvectors of the pair of eigensystems
!! being combined by the matrix of eigenvectors of the K-by-K system
!! which is solved here.
!! 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.
! -- 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) :: k, ldq, n, n1
real(dp), intent(in) :: rho
! Array Arguments
integer(${ik}$), intent(in) :: ctot(*), indx(*)
real(dp), intent(out) :: d(*), q(ldq,*), s(*)
real(dp), intent(inout) :: dlamda(*), w(*)
real(dp), intent(in) :: q2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, iq2, j, n12, n2, n23
real(dp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( n<k ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED3', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, k
dlamda( i ) = stdlib${ii}$_dlamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = 1, k
call stdlib${ii}$_dlaed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1 )go to 110
if( k==2_${ik}$ ) then
do j = 1, k
w( 1_${ik}$ ) = q( 1_${ik}$, j )
w( 2_${ik}$ ) = q( 2_${ik}$, j )
ii = indx( 1_${ik}$ )
q( 1_${ik}$, j ) = w( ii )
ii = indx( 2_${ik}$ )
q( 2_${ik}$, j ) = w( ii )
end do
go to 110
end if
! compute updated w.
call stdlib${ii}$_dcopy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_dcopy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
s( i ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_dnrm2( k, s, 1_${ik}$ )
do i = 1, k
ii = indx( i )
q( i, j ) = s( ii ) / temp
end do
end do
! compute the updated eigenvectors.
110 continue
n2 = n - n1
n12 = ctot( 1_${ik}$ ) + ctot( 2_${ik}$ )
n23 = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ )
call stdlib${ii}$_dlacpy( 'A', n23, k, q( ctot( 1_${ik}$ )+1_${ik}$, 1_${ik}$ ), ldq, s, n23 )
iq2 = n1*n12 + 1_${ik}$
if( n23/=0_${ik}$ ) then
call stdlib${ii}$_dgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,zero, q( n1+1, &
1_${ik}$ ), ldq )
else
call stdlib${ii}$_dlaset( 'A', n2, k, zero, zero, q( n1+1, 1_${ik}$ ), ldq )
end if
call stdlib${ii}$_dlacpy( 'A', n12, k, q, ldq, s, n12 )
if( n12/=0_${ik}$ ) then
call stdlib${ii}$_dgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,ldq )
else
call stdlib${ii}$_dlaset( 'A', n1, k, zero, zero, q( 1_${ik}$, 1_${ik}$ ), ldq )
end if
120 continue
return
end subroutine stdlib${ii}$_dlaed3
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info )
!! DLAED3: finds the roots of the secular equation, as defined by the
!! values in D, W, and RHO, between 1 and K. It makes the
!! appropriate calls to DLAED4 and then updates the eigenvectors by
!! multiplying the matrix of eigenvectors of the pair of eigensystems
!! being combined by the matrix of eigenvectors of the K-by-K system
!! which is solved here.
!! 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.
! -- 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) :: k, ldq, n, n1
real(${rk}$), intent(in) :: rho
! Array Arguments
integer(${ik}$), intent(in) :: ctot(*), indx(*)
real(${rk}$), intent(out) :: d(*), q(ldq,*), s(*)
real(${rk}$), intent(inout) :: dlamda(*), w(*)
real(${rk}$), intent(in) :: q2(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, ii, iq2, j, n12, n2, n23
real(${rk}$) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( n<k ) then
info = -2_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -6_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED3', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, k
dlamda( i ) = stdlib${ii}$_${ri}$lamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = 1, k
call stdlib${ii}$_${ri}$laed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1 )go to 110
if( k==2_${ik}$ ) then
do j = 1, k
w( 1_${ik}$ ) = q( 1_${ik}$, j )
w( 2_${ik}$ ) = q( 2_${ik}$, j )
ii = indx( 1_${ik}$ )
q( 1_${ik}$, j ) = w( ii )
ii = indx( 2_${ik}$ )
q( 2_${ik}$, j ) = w( ii )
end do
go to 110
end if
! compute updated w.
call stdlib${ii}$_${ri}$copy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_${ri}$copy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
s( i ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_${ri}$nrm2( k, s, 1_${ik}$ )
do i = 1, k
ii = indx( i )
q( i, j ) = s( ii ) / temp
end do
end do
! compute the updated eigenvectors.
110 continue
n2 = n - n1
n12 = ctot( 1_${ik}$ ) + ctot( 2_${ik}$ )
n23 = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ )
call stdlib${ii}$_${ri}$lacpy( 'A', n23, k, q( ctot( 1_${ik}$ )+1_${ik}$, 1_${ik}$ ), ldq, s, n23 )
iq2 = n1*n12 + 1_${ik}$
if( n23/=0_${ik}$ ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,zero, q( n1+1, &
1_${ik}$ ), ldq )
else
call stdlib${ii}$_${ri}$laset( 'A', n2, k, zero, zero, q( n1+1, 1_${ik}$ ), ldq )
end if
call stdlib${ii}$_${ri}$lacpy( 'A', n12, k, q, ldq, s, n12 )
if( n12/=0_${ik}$ ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,ldq )
else
call stdlib${ii}$_${ri}$laset( 'A', n1, k, zero, zero, q( 1_${ik}$, 1_${ik}$ ), ldq )
end if
120 continue
return
end subroutine stdlib${ii}$_${ri}$laed3
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed4( n, i, d, z, delta, rho, dlam, info )
!! This subroutine computes the I-th updated eigenvalue of a symmetric
!! rank-one modification to a diagonal matrix whose elements are
!! given in the array d, and that
!! D(i) < D(j) for i < j
!! and that RHO > 0. This is arranged by the calling routine, and is
!! no loss in generality. The rank-one modified system is thus
!! diag( D ) + RHO * Z * Z_transpose.
!! where we assume the Euclidean norm of Z is 1.
!! The method consists of approximating the rational functions in the
!! secular equation by simpler interpolating rational functions.
! -- 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(in) :: i, n
integer(${ik}$), intent(out) :: info
real(sp), intent(out) :: dlam
real(sp), intent(in) :: rho
! Array Arguments
real(sp), intent(in) :: d(*), z(*)
real(sp), intent(out) :: delta(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
logical(lk) :: orgati, swtch, swtch3
integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter
real(sp) :: a, b, c, del, dltlb, dltub, dphi, dpsi, dw, eps, erretm, eta, midpt, phi, &
prew, psi, rhoinv, tau, temp, temp1, w
! Local Arrays
real(sp) :: zz(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! since this routine is called in an inner loop, we do no argument
! checking.
! quick return for n=1 and 2.
info = 0_${ik}$
if( n==1_${ik}$ ) then
! presumably, i=1 upon entry
dlam = d( 1_${ik}$ ) + rho*z( 1_${ik}$ )*z( 1_${ik}$ )
delta( 1_${ik}$ ) = one
return
end if
if( n==2_${ik}$ ) then
call stdlib${ii}$_slaed5( i, d, z, delta, rho, dlam )
return
end if
! compute machine epsilon
eps = stdlib${ii}$_slamch( 'EPSILON' )
rhoinv = one / rho
! the case i = n
if( i==n ) then
! initialize some basic variables
ii = n - 1_${ik}$
niter = 1_${ik}$
! calculate initial guess
midpt = rho / two
! if ||z||_2 is not one, then temp should be set to
! rho * ||z||_2^2 / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, n - 2
psi = psi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi
w = c + z( ii )*z( ii ) / delta( ii ) +z( n )*z( n ) / delta( n )
if( w<=zero ) then
temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) +z( n )*z( n ) / rho
if( c<=temp ) then
tau = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
end if
! it can be proved that
! d(n)+rho/2 <= lambda(n) < d(n)+tau <= d(n)+rho
dltlb = midpt
dltub = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
! it can be proved that
! d(n) < d(n)+tau < lambda(n) < d(n)+rho/2
dltlb = zero
dltub = midpt
end if
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( c<zero )c = abs( c )
if( c==zero ) then
! eta = b/a
! eta = rho - tau
eta = dltub - tau
else if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_90: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
end do loop_90
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
dlam = d( i ) + tau
go to 250
! end for the case i = n
else
! the case for i < n
niter = 1_${ik}$
ip1 = i + 1_${ik}$
! calculate initial guess
del = d( ip1 ) - d( i )
midpt = del / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, i - 1
psi = psi + z( j )*z( j ) / delta( j )
end do
phi = zero
do j = n, i + 2, -1
phi = phi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi + phi
w = c + z( i )*z( i ) / delta( i ) +z( ip1 )*z( ip1 ) / delta( ip1 )
if( w>zero ) then
! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
! we choose d(i) as origin.
orgati = .true.
a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 )
b = z( i )*z( i )*del
if( a>zero ) then
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
else
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
end if
dltlb = zero
dltub = midpt
else
! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
! we choose d(i+1) as origin.
orgati = .false.
a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 )
b = z( ip1 )*z( ip1 )*del
if( a<zero ) then
tau = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
else
tau = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
end if
dltlb = -midpt
dltub = zero
end if
if( orgati ) then
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
else
do j = 1, n
delta( j ) = ( d( j )-d( ip1 ) ) - tau
end do
end if
if( orgati ) then
ii = i
else
ii = i + 1_${ik}$
end if
iim1 = ii - 1_${ik}$
iip1 = ii + 1_${ik}$
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
w = rhoinv + phi + psi
! w is the value of the secular function with
! its ii-th element removed.
swtch3 = .false.
if( orgati ) then
if( w<zero )swtch3 = .true.
else
if( w>zero )swtch3 = .true.
end if
if( ii==1_${ik}$ .or. ii==n )swtch3 = .false.
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = w + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
if( .not.swtch3 ) then
if( orgati ) then
c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*( dpsi+dphi )
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
zz( 2_${ik}$ ) = z( ii )*z( ii )
call stdlib${ii}$_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
prew = w
do j = 1, n
delta( j ) = delta( j ) - eta
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau+eta )&
*dw
swtch = .false.
if( orgati ) then
if( -w>abs( prew ) / ten )swtch = .true.
else
if( w>abs( prew ) / ten )swtch = .true.
end if
tau = tau + eta
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_240: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
if( .not.swtch3 ) then
if( .not.swtch ) then
if( orgati ) then
c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
else
temp = z( ii ) / delta( ii )
if( orgati ) then
dpsi = dpsi + temp*temp
else
dphi = dphi + temp*temp
end if
c = w - delta( i )*dpsi - delta( ip1 )*dphi
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( .not.swtch ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) +delta( i )*delta( i )*( dpsi+dphi )
end if
else
a = delta( i )*delta( i )*dpsi +delta( ip1 )*delta( ip1 )&
*dphi
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( swtch ) then
c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi
else
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )&
*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )&
*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
end if
call stdlib${ii}$_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
prew = w
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch
end do loop_240
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
end if
250 continue
return
end subroutine stdlib${ii}$_slaed4
pure module subroutine stdlib${ii}$_dlaed4( n, i, d, z, delta, rho, dlam, info )
!! This subroutine computes the I-th updated eigenvalue of a symmetric
!! rank-one modification to a diagonal matrix whose elements are
!! given in the array d, and that
!! D(i) < D(j) for i < j
!! and that RHO > 0. This is arranged by the calling routine, and is
!! no loss in generality. The rank-one modified system is thus
!! diag( D ) + RHO * Z * Z_transpose.
!! where we assume the Euclidean norm of Z is 1.
!! The method consists of approximating the rational functions in the
!! secular equation by simpler interpolating rational functions.
! -- 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(in) :: i, n
integer(${ik}$), intent(out) :: info
real(dp), intent(out) :: dlam
real(dp), intent(in) :: rho
! Array Arguments
real(dp), intent(in) :: d(*), z(*)
real(dp), intent(out) :: delta(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
logical(lk) :: orgati, swtch, swtch3
integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter
real(dp) :: a, b, c, del, dltlb, dltub, dphi, dpsi, dw, eps, erretm, eta, midpt, phi, &
prew, psi, rhoinv, tau, temp, temp1, w
! Local Arrays
real(dp) :: zz(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! since this routine is called in an inner loop, we do no argument
! checking.
! quick return for n=1 and 2.
info = 0_${ik}$
if( n==1_${ik}$ ) then
! presumably, i=1 upon entry
dlam = d( 1_${ik}$ ) + rho*z( 1_${ik}$ )*z( 1_${ik}$ )
delta( 1_${ik}$ ) = one
return
end if
if( n==2_${ik}$ ) then
call stdlib${ii}$_dlaed5( i, d, z, delta, rho, dlam )
return
end if
! compute machine epsilon
eps = stdlib${ii}$_dlamch( 'EPSILON' )
rhoinv = one / rho
! the case i = n
if( i==n ) then
! initialize some basic variables
ii = n - 1_${ik}$
niter = 1_${ik}$
! calculate initial guess
midpt = rho / two
! if ||z||_2 is not one, then temp should be set to
! rho * ||z||_2^2 / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, n - 2
psi = psi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi
w = c + z( ii )*z( ii ) / delta( ii ) +z( n )*z( n ) / delta( n )
if( w<=zero ) then
temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) +z( n )*z( n ) / rho
if( c<=temp ) then
tau = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
end if
! it can be proved that
! d(n)+rho/2 <= lambda(n) < d(n)+tau <= d(n)+rho
dltlb = midpt
dltub = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
! it can be proved that
! d(n) < d(n)+tau < lambda(n) < d(n)+rho/2
dltlb = zero
dltub = midpt
end if
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( c<zero )c = abs( c )
if( c==zero ) then
! eta = b/a
! eta = rho - tau
eta = dltub - tau
else if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_90: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
end do loop_90
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
dlam = d( i ) + tau
go to 250
! end for the case i = n
else
! the case for i < n
niter = 1_${ik}$
ip1 = i + 1_${ik}$
! calculate initial guess
del = d( ip1 ) - d( i )
midpt = del / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, i - 1
psi = psi + z( j )*z( j ) / delta( j )
end do
phi = zero
do j = n, i + 2, -1
phi = phi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi + phi
w = c + z( i )*z( i ) / delta( i ) +z( ip1 )*z( ip1 ) / delta( ip1 )
if( w>zero ) then
! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
! we choose d(i) as origin.
orgati = .true.
a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 )
b = z( i )*z( i )*del
if( a>zero ) then
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
else
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
end if
dltlb = zero
dltub = midpt
else
! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
! we choose d(i+1) as origin.
orgati = .false.
a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 )
b = z( ip1 )*z( ip1 )*del
if( a<zero ) then
tau = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
else
tau = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
end if
dltlb = -midpt
dltub = zero
end if
if( orgati ) then
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
else
do j = 1, n
delta( j ) = ( d( j )-d( ip1 ) ) - tau
end do
end if
if( orgati ) then
ii = i
else
ii = i + 1_${ik}$
end if
iim1 = ii - 1_${ik}$
iip1 = ii + 1_${ik}$
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
w = rhoinv + phi + psi
! w is the value of the secular function with
! its ii-th element removed.
swtch3 = .false.
if( orgati ) then
if( w<zero )swtch3 = .true.
else
if( w>zero )swtch3 = .true.
end if
if( ii==1_${ik}$ .or. ii==n )swtch3 = .false.
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = w + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
if( .not.swtch3 ) then
if( orgati ) then
c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*( dpsi+dphi )
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
zz( 2_${ik}$ ) = z( ii )*z( ii )
call stdlib${ii}$_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
prew = w
do j = 1, n
delta( j ) = delta( j ) - eta
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau+eta )&
*dw
swtch = .false.
if( orgati ) then
if( -w>abs( prew ) / ten )swtch = .true.
else
if( w>abs( prew ) / ten )swtch = .true.
end if
tau = tau + eta
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_240: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
if( .not.swtch3 ) then
if( .not.swtch ) then
if( orgati ) then
c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
else
temp = z( ii ) / delta( ii )
if( orgati ) then
dpsi = dpsi + temp*temp
else
dphi = dphi + temp*temp
end if
c = w - delta( i )*dpsi - delta( ip1 )*dphi
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( .not.swtch ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) +delta( i )*delta( i )*( dpsi+dphi )
end if
else
a = delta( i )*delta( i )*dpsi +delta( ip1 )*delta( ip1 )&
*dphi
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( swtch ) then
c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi
else
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )&
*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )&
*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
end if
call stdlib${ii}$_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
prew = w
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch
end do loop_240
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
end if
250 continue
return
end subroutine stdlib${ii}$_dlaed4
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed4( n, i, d, z, delta, rho, dlam, info )
!! This subroutine computes the I-th updated eigenvalue of a symmetric
!! rank-one modification to a diagonal matrix whose elements are
!! given in the array d, and that
!! D(i) < D(j) for i < j
!! and that RHO > 0. This is arranged by the calling routine, and is
!! no loss in generality. The rank-one modified system is thus
!! diag( D ) + RHO * Z * Z_transpose.
!! where we assume the Euclidean norm of Z is 1.
!! The method consists of approximating the rational functions in the
!! secular equation by simpler interpolating rational functions.
! -- 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(in) :: i, n
integer(${ik}$), intent(out) :: info
real(${rk}$), intent(out) :: dlam
real(${rk}$), intent(in) :: rho
! Array Arguments
real(${rk}$), intent(in) :: d(*), z(*)
real(${rk}$), intent(out) :: delta(*)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 30_${ik}$
! Local Scalars
logical(lk) :: orgati, swtch, swtch3
integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter
real(${rk}$) :: a, b, c, del, dltlb, dltub, dphi, dpsi, dw, eps, erretm, eta, midpt, phi, &
prew, psi, rhoinv, tau, temp, temp1, w
! Local Arrays
real(${rk}$) :: zz(3_${ik}$)
! Intrinsic Functions
! Executable Statements
! since this routine is called in an inner loop, we do no argument
! checking.
! quick return for n=1 and 2.
info = 0_${ik}$
if( n==1_${ik}$ ) then
! presumably, i=1 upon entry
dlam = d( 1_${ik}$ ) + rho*z( 1_${ik}$ )*z( 1_${ik}$ )
delta( 1_${ik}$ ) = one
return
end if
if( n==2_${ik}$ ) then
call stdlib${ii}$_${ri}$laed5( i, d, z, delta, rho, dlam )
return
end if
! compute machine epsilon
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
rhoinv = one / rho
! the case i = n
if( i==n ) then
! initialize some basic variables
ii = n - 1_${ik}$
niter = 1_${ik}$
! calculate initial guess
midpt = rho / two
! if ||z||_2 is not one, then temp should be set to
! rho * ||z||_2^2 / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, n - 2
psi = psi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi
w = c + z( ii )*z( ii ) / delta( ii ) +z( n )*z( n ) / delta( n )
if( w<=zero ) then
temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) +z( n )*z( n ) / rho
if( c<=temp ) then
tau = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
end if
! it can be proved that
! d(n)+rho/2 <= lambda(n) < d(n)+tau <= d(n)+rho
dltlb = midpt
dltub = rho
else
del = d( n ) - d( n-1 )
a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
b = z( n )*z( n )*del
if( a<zero ) then
tau = two*b / ( sqrt( a*a+four*b*c )-a )
else
tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
end if
! it can be proved that
! d(n) < d(n)+tau < lambda(n) < d(n)+rho/2
dltlb = zero
dltub = midpt
end if
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( c<zero )c = abs( c )
if( c==zero ) then
! eta = b/a
! eta = rho - tau
eta = dltub - tau
else if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_90: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
dlam = d( i ) + tau
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
c = w - delta( n-1 )*dpsi - delta( n )*dphi
a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi )
b = delta( n-1 )*delta( n )*w
if( a>=zero ) then
eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>zero )eta = -w / ( dpsi+dphi )
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, ii
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
temp = z( n ) / delta( n )
phi = z( n )*temp
dphi = temp*temp
erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +abs( tau )*( dpsi+dphi )
w = rhoinv + phi + psi
end do loop_90
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
dlam = d( i ) + tau
go to 250
! end for the case i = n
else
! the case for i < n
niter = 1_${ik}$
ip1 = i + 1_${ik}$
! calculate initial guess
del = d( ip1 ) - d( i )
midpt = del / two
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - midpt
end do
psi = zero
do j = 1, i - 1
psi = psi + z( j )*z( j ) / delta( j )
end do
phi = zero
do j = n, i + 2, -1
phi = phi + z( j )*z( j ) / delta( j )
end do
c = rhoinv + psi + phi
w = c + z( i )*z( i ) / delta( i ) +z( ip1 )*z( ip1 ) / delta( ip1 )
if( w>zero ) then
! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
! we choose d(i) as origin.
orgati = .true.
a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 )
b = z( i )*z( i )*del
if( a>zero ) then
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
else
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
end if
dltlb = zero
dltub = midpt
else
! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
! we choose d(i+1) as origin.
orgati = .false.
a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 )
b = z( ip1 )*z( ip1 )*del
if( a<zero ) then
tau = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
else
tau = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
end if
dltlb = -midpt
dltub = zero
end if
if( orgati ) then
do j = 1, n
delta( j ) = ( d( j )-d( i ) ) - tau
end do
else
do j = 1, n
delta( j ) = ( d( j )-d( ip1 ) ) - tau
end do
end if
if( orgati ) then
ii = i
else
ii = i + 1_${ik}$
end if
iim1 = ii - 1_${ik}$
iip1 = ii + 1_${ik}$
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
w = rhoinv + phi + psi
! w is the value of the secular function with
! its ii-th element removed.
swtch3 = .false.
if( orgati ) then
if( w<zero )swtch3 = .true.
else
if( w>zero )swtch3 = .true.
end if
if( ii==1_${ik}$ .or. ii==n )swtch3 = .false.
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = w + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
niter = niter + 1_${ik}$
if( .not.swtch3 ) then
if( orgati ) then
c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*( dpsi+dphi )
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
zz( 2_${ik}$ ) = z( ii )*z( ii )
call stdlib${ii}$_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
prew = w
do j = 1, n
delta( j ) = delta( j ) - eta
end do
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau+eta )&
*dw
swtch = .false.
if( orgati ) then
if( -w>abs( prew ) / ten )swtch = .true.
else
if( w>abs( prew ) / ten )swtch = .true.
end if
tau = tau + eta
! main loop to update the values of the array delta
iter = niter + 1_${ik}$
loop_240: do niter = iter, maxit
! test for convergence
if( abs( w )<=eps*erretm ) then
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
go to 250
end if
if( w<=zero ) then
dltlb = max( dltlb, tau )
else
dltub = min( dltub, tau )
end if
! calculate the new step
if( .not.swtch3 ) then
if( .not.swtch ) then
if( orgati ) then
c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )&
**2_${ik}$
else
c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )&
**2_${ik}$
end if
else
temp = z( ii ) / delta( ii )
if( orgati ) then
dpsi = dpsi + temp*temp
else
dphi = dphi + temp*temp
end if
c = w - delta( i )*dpsi - delta( ip1 )*dphi
end if
a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw
b = delta( i )*delta( ip1 )*w
if( c==zero ) then
if( a==zero ) then
if( .not.swtch ) then
if( orgati ) then
a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*( dpsi+dphi )
else
a = z( ip1 )*z( ip1 ) +delta( i )*delta( i )*( dpsi+dphi )
end if
else
a = delta( i )*delta( i )*dpsi +delta( ip1 )*delta( ip1 )&
*dphi
end if
end if
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
else
! interpolation using three most relevant poles
temp = rhoinv + psi + phi
if( swtch ) then
c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi
else
if( orgati ) then
temp1 = z( iim1 ) / delta( iim1 )
temp1 = temp1*temp1
c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )&
*temp1
zz( 1_${ik}$ ) = z( iim1 )*z( iim1 )
zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi )
else
temp1 = z( iip1 ) / delta( iip1 )
temp1 = temp1*temp1
c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )&
*temp1
zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) )
zz( 3_${ik}$ ) = z( iip1 )*z( iip1 )
end if
end if
call stdlib${ii}$_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info )
if( info/=0 )go to 250
end if
! note, eta should be positive if w is negative, and
! eta should be negative otherwise. however,
! if for some reason caused by roundoff, eta*w > 0,
! we simply use one newton step instead. this way
! will guarantee eta*w < 0.
if( w*eta>=zero )eta = -w / dw
temp = tau + eta
if( temp>dltub .or. temp<dltlb ) then
if( w<zero ) then
eta = ( dltub-tau ) / two
else
eta = ( dltlb-tau ) / two
end if
end if
do j = 1, n
delta( j ) = delta( j ) - eta
end do
tau = tau + eta
prew = w
! evaluate psi and the derivative dpsi
dpsi = zero
psi = zero
erretm = zero
do j = 1, iim1
temp = z( j ) / delta( j )
psi = psi + z( j )*temp
dpsi = dpsi + temp*temp
erretm = erretm + psi
end do
erretm = abs( erretm )
! evaluate phi and the derivative dphi
dphi = zero
phi = zero
do j = n, iip1, -1
temp = z( j ) / delta( j )
phi = phi + z( j )*temp
dphi = dphi + temp*temp
erretm = erretm + phi
end do
temp = z( ii ) / delta( ii )
dw = dpsi + dphi + temp*temp
temp = z( ii )*temp
w = rhoinv + phi + psi + temp
erretm = eight*( phi-psi ) + erretm + two*rhoinv +three*abs( temp ) + abs( tau )&
*dw
if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch
end do loop_240
! return with info = 1, niter = maxit and not converged
info = 1_${ik}$
if( orgati ) then
dlam = d( i ) + tau
else
dlam = d( ip1 ) + tau
end if
end if
250 continue
return
end subroutine stdlib${ii}$_${ri}$laed4
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed5( i, d, z, delta, rho, dlam )
!! This subroutine computes the I-th eigenvalue of a symmetric rank-one
!! modification of a 2-by-2 diagonal matrix
!! diag( D ) + RHO * Z * transpose(Z) .
!! The diagonal elements in the array D are assumed to satisfy
!! D(i) < D(j) for i < j .
!! We also assume RHO > 0 and that the Euclidean norm of the vector
!! Z is one.
! -- 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(in) :: i
real(sp), intent(out) :: dlam
real(sp), intent(in) :: rho
! Array Arguments
real(sp), intent(in) :: d(2_${ik}$), z(2_${ik}$)
real(sp), intent(out) :: delta(2_${ik}$)
! =====================================================================
! Local Scalars
real(sp) :: b, c, del, tau, temp, w
! Intrinsic Functions
! Executable Statements
del = d( 2_${ik}$ ) - d( 1_${ik}$ )
if( i==1_${ik}$ ) then
w = one + two*rho*( z( 2_${ik}$ )*z( 2_${ik}$ )-z( 1_${ik}$ )*z( 1_${ik}$ ) ) / del
if( w>zero ) then
b = del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 1_${ik}$ )*z( 1_${ik}$ )*del
! b > zero, always
tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
dlam = d( 1_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / tau
delta( 2_${ik}$ ) = z( 2_${ik}$ ) / ( del-tau )
else
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = -two*c / ( b+sqrt( b*b+four*c ) )
else
tau = ( b-sqrt( b*b+four*c ) ) / two
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
end if
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
else
! now i=2
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = ( b+sqrt( b*b+four*c ) ) / two
else
tau = two*c / ( -b+sqrt( b*b+four*c ) )
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
end if
return
end subroutine stdlib${ii}$_slaed5
pure module subroutine stdlib${ii}$_dlaed5( i, d, z, delta, rho, dlam )
!! This subroutine computes the I-th eigenvalue of a symmetric rank-one
!! modification of a 2-by-2 diagonal matrix
!! diag( D ) + RHO * Z * transpose(Z) .
!! The diagonal elements in the array D are assumed to satisfy
!! D(i) < D(j) for i < j .
!! We also assume RHO > 0 and that the Euclidean norm of the vector
!! Z is one.
! -- 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(in) :: i
real(dp), intent(out) :: dlam
real(dp), intent(in) :: rho
! Array Arguments
real(dp), intent(in) :: d(2_${ik}$), z(2_${ik}$)
real(dp), intent(out) :: delta(2_${ik}$)
! =====================================================================
! Local Scalars
real(dp) :: b, c, del, tau, temp, w
! Intrinsic Functions
! Executable Statements
del = d( 2_${ik}$ ) - d( 1_${ik}$ )
if( i==1_${ik}$ ) then
w = one + two*rho*( z( 2_${ik}$ )*z( 2_${ik}$ )-z( 1_${ik}$ )*z( 1_${ik}$ ) ) / del
if( w>zero ) then
b = del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 1_${ik}$ )*z( 1_${ik}$ )*del
! b > zero, always
tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
dlam = d( 1_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / tau
delta( 2_${ik}$ ) = z( 2_${ik}$ ) / ( del-tau )
else
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = -two*c / ( b+sqrt( b*b+four*c ) )
else
tau = ( b-sqrt( b*b+four*c ) ) / two
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
end if
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
else
! now i=2
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = ( b+sqrt( b*b+four*c ) ) / two
else
tau = two*c / ( -b+sqrt( b*b+four*c ) )
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
end if
return
end subroutine stdlib${ii}$_dlaed5
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed5( i, d, z, delta, rho, dlam )
!! This subroutine computes the I-th eigenvalue of a symmetric rank-one
!! modification of a 2-by-2 diagonal matrix
!! diag( D ) + RHO * Z * transpose(Z) .
!! The diagonal elements in the array D are assumed to satisfy
!! D(i) < D(j) for i < j .
!! We also assume RHO > 0 and that the Euclidean norm of the vector
!! Z is one.
! -- 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(in) :: i
real(${rk}$), intent(out) :: dlam
real(${rk}$), intent(in) :: rho
! Array Arguments
real(${rk}$), intent(in) :: d(2_${ik}$), z(2_${ik}$)
real(${rk}$), intent(out) :: delta(2_${ik}$)
! =====================================================================
! Local Scalars
real(${rk}$) :: b, c, del, tau, temp, w
! Intrinsic Functions
! Executable Statements
del = d( 2_${ik}$ ) - d( 1_${ik}$ )
if( i==1_${ik}$ ) then
w = one + two*rho*( z( 2_${ik}$ )*z( 2_${ik}$ )-z( 1_${ik}$ )*z( 1_${ik}$ ) ) / del
if( w>zero ) then
b = del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 1_${ik}$ )*z( 1_${ik}$ )*del
! b > zero, always
tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
dlam = d( 1_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / tau
delta( 2_${ik}$ ) = z( 2_${ik}$ ) / ( del-tau )
else
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = -two*c / ( b+sqrt( b*b+four*c ) )
else
tau = ( b-sqrt( b*b+four*c ) ) / two
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
end if
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
else
! now i=2
b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) )
c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del
if( b>zero ) then
tau = ( b+sqrt( b*b+four*c ) ) / two
else
tau = two*c / ( -b+sqrt( b*b+four*c ) )
end if
dlam = d( 2_${ik}$ ) + tau
delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau )
delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau
temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) )
delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp
delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp
end if
return
end subroutine stdlib${ii}$_${ri}$laed5
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed6( kniter, orgati, rho, d, z, finit, tau, info )
!! SLAED6 computes the positive or negative root (closest to the origin)
!! of
!! z(1) z(2) z(3)
!! f(x) = rho + --------- + ---------- + ---------
!! d(1)-x d(2)-x d(3)-x
!! It is assumed that
!! if ORGATI = .true. the root is between d(2) and d(3);
!! otherwise it is between d(1) and d(2)
!! This routine will be called by SLAED4 when necessary. In most cases,
!! the root sought is the smallest in magnitude, though it might not be
!! in some extremely rare situations.
! -- 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
logical(lk), intent(in) :: orgati
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kniter
real(sp), intent(in) :: finit, rho
real(sp), intent(out) :: tau
! Array Arguments
real(sp), intent(in) :: d(3_${ik}$), z(3_${ik}$)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 40_${ik}$
! Local Arrays
real(sp) :: dscale(3_${ik}$), zscale(3_${ik}$)
! Local Scalars
logical(lk) :: scale
integer(${ik}$) :: i, iter, niter
real(sp) :: a, b, base, c, ddf, df, eps, erretm, eta, f, fc, sclfac, sclinv, small1, &
small2, sminv1, sminv2, temp, temp1, temp2, temp3, temp4, lbd, ubd
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( orgati ) then
lbd = d(2_${ik}$)
ubd = d(3_${ik}$)
else
lbd = d(1_${ik}$)
ubd = d(2_${ik}$)
end if
if( finit < zero )then
lbd = zero
else
ubd = zero
end if
niter = 1_${ik}$
tau = zero
if( kniter==2_${ik}$ ) then
if( orgati ) then
temp = ( d( 3_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 1_${ik}$ ) / ( ( d( 1_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 2_${ik}$ )+d( 3_${ik}$ ) ) + z( 2_${ik}$ ) + z( 3_${ik}$ )
b = c*d( 2_${ik}$ )*d( 3_${ik}$ ) + z( 2_${ik}$ )*d( 3_${ik}$ ) + z( 3_${ik}$ )*d( 2_${ik}$ )
else
temp = ( d( 1_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 3_${ik}$ ) / ( ( d( 3_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 1_${ik}$ )+d( 2_${ik}$ ) ) + z( 1_${ik}$ ) + z( 2_${ik}$ )
b = c*d( 1_${ik}$ )*d( 2_${ik}$ ) + z( 1_${ik}$ )*d( 2_${ik}$ ) + z( 2_${ik}$ )*d( 1_${ik}$ )
end if
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
tau = b / a
else if( a<=zero ) then
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( tau < lbd .or. tau > ubd )tau = ( lbd+ubd )/two
if( d(1_${ik}$)==tau .or. d(2_${ik}$)==tau .or. d(3_${ik}$)==tau ) then
tau = zero
else
temp = finit + tau*z(1_${ik}$)/( d(1_${ik}$)*( d( 1_${ik}$ )-tau ) ) +tau*z(2_${ik}$)/( d(2_${ik}$)*( d( 2_${ik}$ )-tau ) )&
+tau*z(3_${ik}$)/( d(3_${ik}$)*( d( 3_${ik}$ )-tau ) )
if( temp <= zero )then
lbd = tau
else
ubd = tau
end if
if( abs( finit )<=abs( temp ) )tau = zero
end if
end if
! get machine parameters for possible scaling to avoid overflow
! modified by sven: parameters small1, sminv1, small2,
! sminv2, eps are not saved anymore between one call to the
! others but recomputed at each call
eps = stdlib${ii}$_slamch( 'EPSILON' )
base = stdlib${ii}$_slamch( 'BASE' )
small1 = base**( int( log( stdlib${ii}$_slamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) )
sminv1 = one / small1
small2 = small1*small1
sminv2 = sminv1*sminv1
! determine if scaling of inputs necessary to avoid overflow
! when computing 1/temp**3
if( orgati ) then
temp = min( abs( d( 2_${ik}$ )-tau ), abs( d( 3_${ik}$ )-tau ) )
else
temp = min( abs( d( 1_${ik}$ )-tau ), abs( d( 2_${ik}$ )-tau ) )
end if
scale = .false.
if( temp<=small1 ) then
scale = .true.
if( temp<=small2 ) then
! scale up by power of radix nearest 1/safmin**(2/3)
sclfac = sminv2
sclinv = small2
else
! scale up by power of radix nearest 1/safmin**(1/3)
sclfac = sminv1
sclinv = small1
end if
! scaling up safe because d, z, tau scaled elsewhere to be o(1)
do i = 1, 3
dscale( i ) = d( i )*sclfac
zscale( i ) = z( i )*sclfac
end do
tau = tau*sclfac
lbd = lbd*sclfac
ubd = ubd*sclfac
else
! copy d and z to dscale and zscale
do i = 1, 3
dscale( i ) = d( i )
zscale( i ) = z( i )
end do
end if
fc = zero
df = zero
ddf = zero
do i = 1, 3
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
fc = fc + temp1 / dscale( i )
df = df + temp2
ddf = ddf + temp3
end do
f = finit + tau*fc
if( abs( f )<=zero )go to 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
! iteration begins -- use gragg-thornton-warner cubic convergent
! scheme
! it is not hard to see that
! 1) iterations will go up monotonically
! if finit < 0;
! 2) iterations will go down monotonically
! if finit > 0.
iter = niter + 1_${ik}$
loop_50: do niter = iter, maxit
if( orgati ) then
temp1 = dscale( 2_${ik}$ ) - tau
temp2 = dscale( 3_${ik}$ ) - tau
else
temp1 = dscale( 1_${ik}$ ) - tau
temp2 = dscale( 2_${ik}$ ) - tau
end if
a = ( temp1+temp2 )*f - temp1*temp2*df
b = temp1*temp2*f
c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( f*eta>=zero ) then
eta = -f / df
end if
tau = tau + eta
if( tau < lbd .or. tau > ubd )tau = ( lbd + ubd )/two
fc = zero
erretm = zero
df = zero
ddf = zero
do i = 1, 3
if ( ( dscale( i )-tau )/=zero ) then
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
temp4 = temp1 / dscale( i )
fc = fc + temp4
erretm = erretm + abs( temp4 )
df = df + temp2
ddf = ddf + temp3
else
go to 60
end if
end do
f = finit + tau*fc
erretm = eight*( abs( finit )+abs( tau )*erretm ) +abs( tau )*df
if( ( abs( f )<=four*eps*erretm ) .or.( (ubd-lbd)<=four*eps*abs(tau) ) )go to 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
end do loop_50
info = 1_${ik}$
60 continue
! undo scaling
if( scale )tau = tau*sclinv
return
end subroutine stdlib${ii}$_slaed6
pure module subroutine stdlib${ii}$_dlaed6( kniter, orgati, rho, d, z, finit, tau, info )
!! DLAED6 computes the positive or negative root (closest to the origin)
!! of
!! z(1) z(2) z(3)
!! f(x) = rho + --------- + ---------- + ---------
!! d(1)-x d(2)-x d(3)-x
!! It is assumed that
!! if ORGATI = .true. the root is between d(2) and d(3);
!! otherwise it is between d(1) and d(2)
!! This routine will be called by DLAED4 when necessary. In most cases,
!! the root sought is the smallest in magnitude, though it might not be
!! in some extremely rare situations.
! -- 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
logical(lk), intent(in) :: orgati
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kniter
real(dp), intent(in) :: finit, rho
real(dp), intent(out) :: tau
! Array Arguments
real(dp), intent(in) :: d(3_${ik}$), z(3_${ik}$)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 40_${ik}$
! Local Arrays
real(dp) :: dscale(3_${ik}$), zscale(3_${ik}$)
! Local Scalars
logical(lk) :: scale
integer(${ik}$) :: i, iter, niter
real(dp) :: a, b, base, c, ddf, df, eps, erretm, eta, f, fc, sclfac, sclinv, small1, &
small2, sminv1, sminv2, temp, temp1, temp2, temp3, temp4, lbd, ubd
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( orgati ) then
lbd = d(2_${ik}$)
ubd = d(3_${ik}$)
else
lbd = d(1_${ik}$)
ubd = d(2_${ik}$)
end if
if( finit < zero )then
lbd = zero
else
ubd = zero
end if
niter = 1_${ik}$
tau = zero
if( kniter==2_${ik}$ ) then
if( orgati ) then
temp = ( d( 3_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 1_${ik}$ ) / ( ( d( 1_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 2_${ik}$ )+d( 3_${ik}$ ) ) + z( 2_${ik}$ ) + z( 3_${ik}$ )
b = c*d( 2_${ik}$ )*d( 3_${ik}$ ) + z( 2_${ik}$ )*d( 3_${ik}$ ) + z( 3_${ik}$ )*d( 2_${ik}$ )
else
temp = ( d( 1_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 3_${ik}$ ) / ( ( d( 3_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 1_${ik}$ )+d( 2_${ik}$ ) ) + z( 1_${ik}$ ) + z( 2_${ik}$ )
b = c*d( 1_${ik}$ )*d( 2_${ik}$ ) + z( 1_${ik}$ )*d( 2_${ik}$ ) + z( 2_${ik}$ )*d( 1_${ik}$ )
end if
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
tau = b / a
else if( a<=zero ) then
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( tau < lbd .or. tau > ubd )tau = ( lbd+ubd )/two
if( d(1_${ik}$)==tau .or. d(2_${ik}$)==tau .or. d(3_${ik}$)==tau ) then
tau = zero
else
temp = finit + tau*z(1_${ik}$)/( d(1_${ik}$)*( d( 1_${ik}$ )-tau ) ) +tau*z(2_${ik}$)/( d(2_${ik}$)*( d( 2_${ik}$ )-tau ) )&
+tau*z(3_${ik}$)/( d(3_${ik}$)*( d( 3_${ik}$ )-tau ) )
if( temp <= zero )then
lbd = tau
else
ubd = tau
end if
if( abs( finit )<=abs( temp ) )tau = zero
end if
end if
! get machine parameters for possible scaling to avoid overflow
! modified by sven: parameters small1, sminv1, small2,
! sminv2, eps are not saved anymore between one call to the
! others but recomputed at each call
eps = stdlib${ii}$_dlamch( 'EPSILON' )
base = stdlib${ii}$_dlamch( 'BASE' )
small1 = base**( int( log( stdlib${ii}$_dlamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) )
sminv1 = one / small1
small2 = small1*small1
sminv2 = sminv1*sminv1
! determine if scaling of inputs necessary to avoid overflow
! when computing 1/temp**3
if( orgati ) then
temp = min( abs( d( 2_${ik}$ )-tau ), abs( d( 3_${ik}$ )-tau ) )
else
temp = min( abs( d( 1_${ik}$ )-tau ), abs( d( 2_${ik}$ )-tau ) )
end if
scale = .false.
if( temp<=small1 ) then
scale = .true.
if( temp<=small2 ) then
! scale up by power of radix nearest 1/safmin**(2/3)
sclfac = sminv2
sclinv = small2
else
! scale up by power of radix nearest 1/safmin**(1/3)
sclfac = sminv1
sclinv = small1
end if
! scaling up safe because d, z, tau scaled elsewhere to be o(1)
do i = 1, 3
dscale( i ) = d( i )*sclfac
zscale( i ) = z( i )*sclfac
end do
tau = tau*sclfac
lbd = lbd*sclfac
ubd = ubd*sclfac
else
! copy d and z to dscale and zscale
do i = 1, 3
dscale( i ) = d( i )
zscale( i ) = z( i )
end do
end if
fc = zero
df = zero
ddf = zero
do i = 1, 3
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
fc = fc + temp1 / dscale( i )
df = df + temp2
ddf = ddf + temp3
end do
f = finit + tau*fc
if( abs( f )<=zero )go to 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
! iteration begins -- use gragg-thornton-warner cubic convergent
! scheme
! it is not hard to see that
! 1) iterations will go up monotonically
! if finit < 0;
! 2) iterations will go down monotonically
! if finit > 0.
iter = niter + 1_${ik}$
loop_50: do niter = iter, maxit
if( orgati ) then
temp1 = dscale( 2_${ik}$ ) - tau
temp2 = dscale( 3_${ik}$ ) - tau
else
temp1 = dscale( 1_${ik}$ ) - tau
temp2 = dscale( 2_${ik}$ ) - tau
end if
a = ( temp1+temp2 )*f - temp1*temp2*df
b = temp1*temp2*f
c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( f*eta>=zero ) then
eta = -f / df
end if
tau = tau + eta
if( tau < lbd .or. tau > ubd )tau = ( lbd + ubd )/two
fc = zero
erretm = zero
df = zero
ddf = zero
do i = 1, 3
if ( ( dscale( i )-tau )/=zero ) then
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
temp4 = temp1 / dscale( i )
fc = fc + temp4
erretm = erretm + abs( temp4 )
df = df + temp2
ddf = ddf + temp3
else
go to 60
end if
end do
f = finit + tau*fc
erretm = eight*( abs( finit )+abs( tau )*erretm ) +abs( tau )*df
if( ( abs( f )<=four*eps*erretm ) .or.( (ubd-lbd)<=four*eps*abs(tau) ) ) go to 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
end do loop_50
info = 1_${ik}$
60 continue
! undo scaling
if( scale )tau = tau*sclinv
return
end subroutine stdlib${ii}$_dlaed6
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed6( kniter, orgati, rho, d, z, finit, tau, info )
!! DLAED6: computes the positive or negative root (closest to the origin)
!! of
!! z(1) z(2) z(3)
!! f(x) = rho + --------- + ---------- + ---------
!! d(1)-x d(2)-x d(3)-x
!! It is assumed that
!! if ORGATI = .true. the root is between d(2) and d(3);
!! otherwise it is between d(1) and d(2)
!! This routine will be called by DLAED4 when necessary. In most cases,
!! the root sought is the smallest in magnitude, though it might not be
!! in some extremely rare situations.
! -- 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
logical(lk), intent(in) :: orgati
integer(${ik}$), intent(out) :: info
integer(${ik}$), intent(in) :: kniter
real(${rk}$), intent(in) :: finit, rho
real(${rk}$), intent(out) :: tau
! Array Arguments
real(${rk}$), intent(in) :: d(3_${ik}$), z(3_${ik}$)
! =====================================================================
! Parameters
integer(${ik}$), parameter :: maxit = 40_${ik}$
! Local Arrays
real(${rk}$) :: dscale(3_${ik}$), zscale(3_${ik}$)
! Local Scalars
logical(lk) :: scale
integer(${ik}$) :: i, iter, niter
real(${rk}$) :: a, b, base, c, ddf, df, eps, erretm, eta, f, fc, sclfac, sclinv, small1, &
small2, sminv1, sminv2, temp, temp1, temp2, temp3, temp4, lbd, ubd
! Intrinsic Functions
! Executable Statements
info = 0_${ik}$
if( orgati ) then
lbd = d(2_${ik}$)
ubd = d(3_${ik}$)
else
lbd = d(1_${ik}$)
ubd = d(2_${ik}$)
end if
if( finit < zero )then
lbd = zero
else
ubd = zero
end if
niter = 1_${ik}$
tau = zero
if( kniter==2_${ik}$ ) then
if( orgati ) then
temp = ( d( 3_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 1_${ik}$ ) / ( ( d( 1_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 2_${ik}$ )+d( 3_${ik}$ ) ) + z( 2_${ik}$ ) + z( 3_${ik}$ )
b = c*d( 2_${ik}$ )*d( 3_${ik}$ ) + z( 2_${ik}$ )*d( 3_${ik}$ ) + z( 3_${ik}$ )*d( 2_${ik}$ )
else
temp = ( d( 1_${ik}$ )-d( 2_${ik}$ ) ) / two
c = rho + z( 3_${ik}$ ) / ( ( d( 3_${ik}$ )-d( 2_${ik}$ ) )-temp )
a = c*( d( 1_${ik}$ )+d( 2_${ik}$ ) ) + z( 1_${ik}$ ) + z( 2_${ik}$ )
b = c*d( 1_${ik}$ )*d( 2_${ik}$ ) + z( 1_${ik}$ )*d( 2_${ik}$ ) + z( 2_${ik}$ )*d( 1_${ik}$ )
end if
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
tau = b / a
else if( a<=zero ) then
tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( tau < lbd .or. tau > ubd )tau = ( lbd+ubd )/two
if( d(1_${ik}$)==tau .or. d(2_${ik}$)==tau .or. d(3_${ik}$)==tau ) then
tau = zero
else
temp = finit + tau*z(1_${ik}$)/( d(1_${ik}$)*( d( 1_${ik}$ )-tau ) ) +tau*z(2_${ik}$)/( d(2_${ik}$)*( d( 2_${ik}$ )-tau ) )&
+tau*z(3_${ik}$)/( d(3_${ik}$)*( d( 3_${ik}$ )-tau ) )
if( temp <= zero )then
lbd = tau
else
ubd = tau
end if
if( abs( finit )<=abs( temp ) )tau = zero
end if
end if
! get machine parameters for possible scaling to avoid overflow
! modified by sven: parameters small1, sminv1, small2,
! sminv2, eps are not saved anymore between one call to the
! others but recomputed at each call
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
base = stdlib${ii}$_${ri}$lamch( 'BASE' )
small1 = base**( int( log( stdlib${ii}$_${ri}$lamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) )
sminv1 = one / small1
small2 = small1*small1
sminv2 = sminv1*sminv1
! determine if scaling of inputs necessary to avoid overflow
! when computing 1/temp**3
if( orgati ) then
temp = min( abs( d( 2_${ik}$ )-tau ), abs( d( 3_${ik}$ )-tau ) )
else
temp = min( abs( d( 1_${ik}$ )-tau ), abs( d( 2_${ik}$ )-tau ) )
end if
scale = .false.
if( temp<=small1 ) then
scale = .true.
if( temp<=small2 ) then
! scale up by power of radix nearest 1/safmin**(2/3)
sclfac = sminv2
sclinv = small2
else
! scale up by power of radix nearest 1/safmin**(1/3)
sclfac = sminv1
sclinv = small1
end if
! scaling up safe because d, z, tau scaled elsewhere to be o(1)
do i = 1, 3
dscale( i ) = d( i )*sclfac
zscale( i ) = z( i )*sclfac
end do
tau = tau*sclfac
lbd = lbd*sclfac
ubd = ubd*sclfac
else
! copy d and z to dscale and zscale
do i = 1, 3
dscale( i ) = d( i )
zscale( i ) = z( i )
end do
end if
fc = zero
df = zero
ddf = zero
do i = 1, 3
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
fc = fc + temp1 / dscale( i )
df = df + temp2
ddf = ddf + temp3
end do
f = finit + tau*fc
if( abs( f )<=zero )go to 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
! iteration begins -- use gragg-thornton-warner cubic convergent
! scheme
! it is not hard to see that
! 1) iterations will go up monotonically
! if finit < 0;
! 2) iterations will go down monotonically
! if finit > 0.
iter = niter + 1_${ik}$
loop_50: do niter = iter, maxit
if( orgati ) then
temp1 = dscale( 2_${ik}$ ) - tau
temp2 = dscale( 3_${ik}$ ) - tau
else
temp1 = dscale( 1_${ik}$ ) - tau
temp2 = dscale( 2_${ik}$ ) - tau
end if
a = ( temp1+temp2 )*f - temp1*temp2*df
b = temp1*temp2*f
c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
temp = max( abs( a ), abs( b ), abs( c ) )
a = a / temp
b = b / temp
c = c / temp
if( c==zero ) then
eta = b / a
else if( a<=zero ) then
eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
else
eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
end if
if( f*eta>=zero ) then
eta = -f / df
end if
tau = tau + eta
if( tau < lbd .or. tau > ubd )tau = ( lbd + ubd )/two
fc = zero
erretm = zero
df = zero
ddf = zero
do i = 1, 3
if ( ( dscale( i )-tau )/=zero ) then
temp = one / ( dscale( i )-tau )
temp1 = zscale( i )*temp
temp2 = temp1*temp
temp3 = temp2*temp
temp4 = temp1 / dscale( i )
fc = fc + temp4
erretm = erretm + abs( temp4 )
df = df + temp2
ddf = ddf + temp3
else
go to 60
end if
end do
f = finit + tau*fc
erretm = eight*( abs( finit )+abs( tau )*erretm ) +abs( tau )*df
if( ( abs( f )<=four*eps*erretm ) .or.( (ubd-lbd)<=four*eps*abs(tau) ) ) goto 60
if( f <= zero )then
lbd = tau
else
ubd = tau
end if
end do loop_50
info = 1_${ik}$
60 continue
! undo scaling
if( scale )tau = tau*sclinv
return
end subroutine stdlib${ii}$_${ri}$laed6
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, rho, &
!! SLAED7 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense symmetric matrix
!! that has been reduced to tridiagonal form. SLAED1 handles
!! the case in which all eigenvalues and eigenvectors of a symmetric
!! tridiagonal matrix are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**Tu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine SLAED8.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine SLAED4 (as called by SLAED9).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, 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
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, icompq, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(sp), intent(inout) :: d(*), givnum(2_${ik}$,*), q(ldq,*), qstore(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, ldq2, &
n1, n2, ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_slaed8 and stdlib${ii}$_slaed9.
if( icompq==1_${ik}$ ) then
ldq2 = qsiz
else
ldq2 = n
end if
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
is = iq2 + n*ldq2
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, work( iz ),work( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt,work( iz ), work(&
idlmda ), work( iq2 ), ldq2,work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ),&
givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), iwork( indxp ),iwork( indx ),&
info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_slaed9( k, 1_${ik}$, k, n, d, work( is ), k, rho, work( idlmda ),work( iw ), &
qstore( qptr( curr ) ), k, info )
if( info/=0 )go to 30
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_sgemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2,qstore( qptr( &
curr ) ), k, zero, q, ldq )
end if
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_slamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
30 continue
return
end subroutine stdlib${ii}$_slaed7
pure module subroutine stdlib${ii}$_dlaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, rho, &
!! DLAED7 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense symmetric matrix
!! that has been reduced to tridiagonal form. DLAED1 handles
!! the case in which all eigenvalues and eigenvectors of a symmetric
!! tridiagonal matrix are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**Tu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED8.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by DLAED9).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, 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
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, icompq, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(dp), intent(inout) :: d(*), givnum(2_${ik}$,*), q(ldq,*), qstore(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, ldq2, &
n1, n2, ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_dlaed8 and stdlib${ii}$_dlaed9.
if( icompq==1_${ik}$ ) then
ldq2 = qsiz
else
ldq2 = n
end if
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
is = iq2 + n*ldq2
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, work( iz ),work( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt,work( iz ), work(&
idlmda ), work( iq2 ), ldq2,work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ),&
givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), iwork( indxp ),iwork( indx ),&
info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_dlaed9( k, 1_${ik}$, k, n, d, work( is ), k, rho, work( idlmda ),work( iw ), &
qstore( qptr( curr ) ), k, info )
if( info/=0 )go to 30
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_dgemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2,qstore( qptr( &
curr ) ), k, zero, q, ldq )
end if
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_dlamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
30 continue
return
end subroutine stdlib${ii}$_dlaed7
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, rho, &
!! DLAED7: computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense symmetric matrix
!! that has been reduced to tridiagonal form. DLAED1 handles
!! the case in which all eigenvalues and eigenvectors of a symmetric
!! tridiagonal matrix are desired.
!! T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!! where Z = Q**Tu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED8.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by DLAED9).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, 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
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, icompq, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(${rk}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(${rk}$), intent(inout) :: d(*), givnum(2_${ik}$,*), q(ldq,*), qstore(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, ldq2, &
n1, n2, ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_${ri}$laed8 and stdlib${ii}$_${ri}$laed9.
if( icompq==1_${ik}$ ) then
ldq2 = qsiz
else
ldq2 = n
end if
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq2 = iw + n
is = iq2 + n*ldq2
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_${ri}$laeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, work( iz ),work( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_${ri}$laed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt,work( iz ), work(&
idlmda ), work( iq2 ), ldq2,work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ),&
givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), iwork( indxp ),iwork( indx ),&
info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_${ri}$laed9( k, 1_${ik}$, k, n, d, work( is ), k, rho, work( idlmda ),work( iw ), &
qstore( qptr( curr ) ), k, info )
if( info/=0 )go to 30
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_${ri}$gemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2,qstore( qptr( &
curr ) ), k, zero, q, ldq )
end if
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
! prepare the indxq sorting permutation.
n1 = k
n2 = n - k
call stdlib${ii}$_${ri}$lamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
30 continue
return
end subroutine stdlib${ii}$_${ri}$laed7
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, indxq, &
!! CLAED7 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense or banded
!! Hermitian matrix that has been reduced to tridiagonal form.
!! T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
!! where Z = Q**Hu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine SLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine SLAED4 (as called by SLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, 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
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(sp), intent(inout) :: d(*), givnum(2_${ik}$,*), qstore(*)
real(sp), intent(out) :: rwork(*)
complex(sp), intent(inout) :: q(ldq,*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq, iw, iz, k, n1, n2, &
ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq<0 .or. icompq>1 ) then
! info = -1
! else if( n<0 ) then
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_slaed2 and stdlib${ii}$_slaed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, rwork( iz ),rwork( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_claed8( k, n, qsiz, q, ldq, d, rho, cutpnt, rwork( iz ),rwork( idlmda ), &
work, qsiz, rwork( iw ),iwork( indxp ), iwork( indx ), indxq,perm( prmptr( curr ) ), &
givptr( curr+1 ),givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_slaed9( k, 1_${ik}$, k, n, d, rwork( iq ), k, rho,rwork( idlmda ), rwork( iw ),&
qstore( qptr( curr ) ), k, info )
call stdlib${ii}$_clacrm( qsiz, k, work, qsiz, qstore( qptr( curr ) ), k, q,ldq, rwork( &
iq ) )
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
if( info/=0_${ik}$ ) then
return
end if
! prepare the indxq sorting premutation.
n1 = k
n2 = n - k
call stdlib${ii}$_slamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
return
end subroutine stdlib${ii}$_claed7
pure module subroutine stdlib${ii}$_zlaed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, indxq, &
!! ZLAED7 computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense or banded
!! Hermitian matrix that has been reduced to tridiagonal form.
!! T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
!! where Z = Q**Hu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by SLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, 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
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(dp), intent(inout) :: d(*), givnum(2_${ik}$,*), qstore(*)
real(dp), intent(out) :: rwork(*)
complex(dp), intent(inout) :: q(ldq,*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq, iw, iz, k, n1, n2, &
ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq<0 .or. icompq>1 ) then
! info = -1
! else if( n<0 ) then
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_dlaed2 and stdlib${ii}$_slaed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, rwork( iz ),rwork( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, rwork( iz ),rwork( idlmda ), &
work, qsiz, rwork( iw ),iwork( indxp ), iwork( indx ), indxq,perm( prmptr( curr ) ), &
givptr( curr+1 ),givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_dlaed9( k, 1_${ik}$, k, n, d, rwork( iq ), k, rho,rwork( idlmda ), rwork( iw ),&
qstore( qptr( curr ) ), k, info )
call stdlib${ii}$_zlacrm( qsiz, k, work, qsiz, qstore( qptr( curr ) ), k, q,ldq, rwork( &
iq ) )
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
if( info/=0_${ik}$ ) then
return
end if
! prepare the indxq sorting premutation.
n1 = k
n2 = n - k
call stdlib${ii}$_dlamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
return
end subroutine stdlib${ii}$_zlaed7
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, indxq, &
!! ZLAED7: computes the updated eigensystem of a diagonal
!! matrix after modification by a rank-one symmetric matrix. This
!! routine is used only for the eigenproblem which requires all
!! eigenvalues and optionally eigenvectors of a dense or banded
!! Hermitian matrix that has been reduced to tridiagonal form.
!! T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out)
!! where Z = Q**Hu, u is a vector of length N with ones in the
!! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!! The eigenvectors of the original matrix are stored in Q, and the
!! eigenvalues are in D. The algorithm consists of three stages:
!! The first stage consists of deflating the size of the problem
!! when there are multiple eigenvalues or if there is a zero in
!! the Z vector. For each such occurrence the dimension of the
!! secular equation problem is reduced by one. This stage is
!! performed by the routine DLAED2.
!! The second stage consists of calculating the updated
!! eigenvalues. This is done by finding the roots of the secular
!! equation via the routine DLAED4 (as called by SLAED3).
!! This routine also calculates the eigenvectors of the current
!! problem.
!! The final stage consists of computing the updated eigenvectors
!! directly using the updated eigenvalues. The eigenvectors for
!! the current problem are multiplied with the eigenvectors from
!! the overall problem.
qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, 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_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, ldq, n, qsiz, tlvls
integer(${ik}$), intent(out) :: info
real(${ck}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*)
integer(${ik}$), intent(out) :: indxq(*), iwork(*)
real(${ck}$), intent(inout) :: d(*), givnum(2_${ik}$,*), qstore(*)
real(${ck}$), intent(out) :: rwork(*)
complex(${ck}$), intent(inout) :: q(ldq,*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq, iw, iz, k, n1, n2, &
ptr
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
! if( icompq<0 .or. icompq>1 ) then
! info = -1
! else if( n<0 ) then
if( n<0_${ik}$ ) then
info = -1_${ik}$
else if( min( 1_${ik}$, n )>cutpnt .or. n<cutpnt ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -9_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED7', -info )
return
end if
! quick return if possible
if( n==0 )return
! the following values are for bookkeeping purposes only. they are
! integer pointers which indicate the portion of the workspace
! used by a particular array in stdlib${ii}$_${c2ri(ci)}$laed2 and stdlib${ii}$_dlaed3.
iz = 1_${ik}$
idlmda = iz + n
iw = idlmda + n
iq = iw + n
indx = 1_${ik}$
indxc = indx + n
coltyp = indxc + n
indxp = coltyp + n
! form the z-vector which consists of the last row of q_1 and the
! first row of q_2.
ptr = 1_${ik}$ + 2_${ik}$**tlvls
do i = 1, curlvl - 1
ptr = ptr + 2_${ik}$**( tlvls-i )
end do
curr = ptr + curpbm
call stdlib${ii}$_${c2ri(ci)}$laeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum, &
qstore, qptr, rwork( iz ),rwork( iz+n ), info )
! when solving the final problem, we no longer need the stored data,
! so we will overwrite the data from this level onto the previously
! used storage space.
if( curlvl==tlvls ) then
qptr( curr ) = 1_${ik}$
prmptr( curr ) = 1_${ik}$
givptr( curr ) = 1_${ik}$
end if
! sort and deflate eigenvalues.
call stdlib${ii}$_${ci}$laed8( k, n, qsiz, q, ldq, d, rho, cutpnt, rwork( iz ),rwork( idlmda ), &
work, qsiz, rwork( iw ),iwork( indxp ), iwork( indx ), indxq,perm( prmptr( curr ) ), &
givptr( curr+1 ),givcol( 1_${ik}$, givptr( curr ) ),givnum( 1_${ik}$, givptr( curr ) ), info )
prmptr( curr+1 ) = prmptr( curr ) + n
givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
! solve secular equation.
if( k/=0_${ik}$ ) then
call stdlib${ii}$_${c2ri(ci)}$laed9( k, 1_${ik}$, k, n, d, rwork( iq ), k, rho,rwork( idlmda ), rwork( iw ),&
qstore( qptr( curr ) ), k, info )
call stdlib${ii}$_${ci}$lacrm( qsiz, k, work, qsiz, qstore( qptr( curr ) ), k, q,ldq, rwork( &
iq ) )
qptr( curr+1 ) = qptr( curr ) + k**2_${ik}$
if( info/=0_${ik}$ ) then
return
end if
! prepare the indxq sorting premutation.
n1 = k
n2 = n - k
call stdlib${ii}$_${c2ri(ci)}$lamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, indxq )
else
qptr( curr+1 ) = qptr( curr )
do i = 1, n
indxq( i ) = i
end do
end if
return
end subroutine stdlib${ii}$_${ci}$laed7
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, &
!! SLAED8 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, 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(in) :: cutpnt, icompq, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(sp), intent(inout) :: d(*), q(ldq,*), z(*)
real(sp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), q2(ldq2,*), w(*)
! =====================================================================
! Parameters
real(sp), parameter :: mone = -1.0_sp
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(sp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -10_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_sscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_sscal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_slamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_isamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_isamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_slamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
if( icompq==0_${ik}$ ) then
do j = 1, n
perm( j ) = indxq( indx( j ) )
end do
else
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_scopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_slacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ),ldq )
end if
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 110
else
jlam = j
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
if( j>n )go to 100
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_slapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_srot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j &
) ) ), 1_${ik}$, c, s )
end if
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
110 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
if( icompq==0_${ik}$ ) then
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
end do
else
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_scopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
if( icompq==0_${ik}$ ) then
call stdlib${ii}$_scopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
else
call stdlib${ii}$_scopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_slacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2,q( 1_${ik}$, k+1 ), ldq )
end if
end if
return
end subroutine stdlib${ii}$_slaed8
pure module subroutine stdlib${ii}$_dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, &
!! DLAED8 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, 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(in) :: cutpnt, icompq, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(dp), intent(inout) :: d(*), q(ldq,*), z(*)
real(dp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), q2(ldq2,*), w(*)
! =====================================================================
! Parameters
real(dp), parameter :: mone = -1.0_dp
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(dp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -10_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_dscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_dscal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_dlamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_idamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_idamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
if( icompq==0_${ik}$ ) then
do j = 1, n
perm( j ) = indxq( indx( j ) )
end do
else
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_dcopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_dlacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ),ldq )
end if
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 110
else
jlam = j
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
if( j>n )go to 100
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_dlapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_drot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j &
) ) ), 1_${ik}$, c, s )
end if
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
110 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
if( icompq==0_${ik}$ ) then
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
end do
else
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_dcopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
if( icompq==0_${ik}$ ) then
call stdlib${ii}$_dcopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
else
call stdlib${ii}$_dcopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_dlacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2,q( 1_${ik}$, k+1 ), ldq )
end if
end if
return
end subroutine stdlib${ii}$_dlaed8
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, &
!! DLAED8: merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, 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(in) :: cutpnt, icompq, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(${rk}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(${rk}$), intent(inout) :: d(*), q(ldq,*), z(*)
real(${rk}$), intent(out) :: dlamda(*), givnum(2_${ik}$,*), q2(ldq2,*), w(*)
! =====================================================================
! Parameters
real(${rk}$), parameter :: mone = -1.0_${rk}$
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(${rk}$) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( icompq<0_${ik}$ .or. icompq>1_${ik}$ ) then
info = -1_${ik}$
else if( n<0_${ik}$ ) then
info = -3_${ik}$
else if( icompq==1_${ik}$ .and. qsiz<n ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -7_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -10_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -14_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_${ri}$scal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_${ri}$scal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_${ri}$lamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_i${ri}$amax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_i${ri}$amax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
if( icompq==0_${ik}$ ) then
do j = 1, n
perm( j ) = indxq( indx( j ) )
end do
else
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_${ri}$copy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_${ri}$lacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ),ldq )
end if
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 110
else
jlam = j
go to 80
end if
end do
80 continue
j = j + 1_${ik}$
if( j>n )go to 100
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_${ri}$lapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
if( icompq==1_${ik}$ ) then
call stdlib${ii}$_${ri}$rot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j &
) ) ), 1_${ik}$, c, s )
end if
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
90 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 90
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 80
100 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
110 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
if( icompq==0_${ik}$ ) then
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
end do
else
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_${ri}$copy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
end if
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
if( icompq==0_${ik}$ ) then
call stdlib${ii}$_${ri}$copy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
else
call stdlib${ii}$_${ri}$copy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ri}$lacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2,q( 1_${ik}$, k+1 ), ldq )
end if
end if
return
end subroutine stdlib${ii}$_${ri}$laed8
#:endif
#:endfor
pure module subroutine stdlib${ii}$_claed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, &
!! CLAED8 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, indx, indxq, perm, givptr,givcol, givnum, 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(in) :: cutpnt, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(sp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(sp), intent(inout) :: d(*), z(*)
real(sp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), w(*)
complex(sp), intent(inout) :: q(ldq,*)
complex(sp), intent(out) :: q2(ldq2,*)
! =====================================================================
! Parameters
real(sp), parameter :: mone = -1.0_sp
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(sp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -8_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'CLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_sscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_sscal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_slamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_isamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_isamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_slamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! -- except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_ccopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_clacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ), ldq )
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 100
else
jlam = j
go to 70
end if
end do
70 continue
j = j + 1_${ik}$
if( j>n )go to 90
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_slapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
call stdlib${ii}$_csrot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) &
) ), 1_${ik}$, c, s )
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
80 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 80
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 70
90 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
100 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_ccopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_scopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_clacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2, q( 1_${ik}$, k+1 ),ldq )
end if
return
end subroutine stdlib${ii}$_claed8
pure module subroutine stdlib${ii}$_zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, &
!! ZLAED8 merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, indx, indxq, perm, givptr,givcol, givnum, 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(in) :: cutpnt, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(dp), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(dp), intent(inout) :: d(*), z(*)
real(dp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), w(*)
complex(dp), intent(inout) :: q(ldq,*)
complex(dp), intent(out) :: q2(ldq2,*)
! =====================================================================
! Parameters
real(dp), parameter :: mone = -1.0_dp
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(dp) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -8_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_dscal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_dscal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_dlamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_idamax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_idamax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_dlamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! -- except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_zcopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_zlacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ), ldq )
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 100
else
jlam = j
go to 70
end if
end do
70 continue
j = j + 1_${ik}$
if( j>n )go to 90
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_dlapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
call stdlib${ii}$_zdrot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) &
) ), 1_${ik}$, c, s )
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
80 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 80
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 70
90 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
100 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_zcopy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_dcopy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_zlacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2, q( 1_${ik}$, k+1 ),ldq )
end if
return
end subroutine stdlib${ii}$_zlaed8
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$laed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, &
!! ZLAED8: merges the two sets of eigenvalues together into a single
!! sorted set. Then it tries to deflate the size of the problem.
!! There are two ways in which deflation can occur: when two or more
!! eigenvalues are close together or if there is a tiny element in the
!! Z vector. For each such occurrence the order of the related secular
!! equation problem is reduced by one.
indxp, indx, indxq, perm, givptr,givcol, givnum, 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(in) :: cutpnt, ldq, ldq2, n, qsiz
integer(${ik}$), intent(out) :: givptr, info, k
real(${ck}$), intent(inout) :: rho
! Array Arguments
integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*)
integer(${ik}$), intent(inout) :: indxq(*)
real(${ck}$), intent(inout) :: d(*), z(*)
real(${ck}$), intent(out) :: dlamda(*), givnum(2_${ik}$,*), w(*)
complex(${ck}$), intent(inout) :: q(ldq,*)
complex(${ck}$), intent(out) :: q2(ldq2,*)
! =====================================================================
! Parameters
real(${ck}$), parameter :: mone = -one
! Local Scalars
integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2
real(${ck}$) :: c, eps, s, t, tau, tol
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( n<0_${ik}$ ) then
info = -2_${ik}$
else if( qsiz<n ) then
info = -3_${ik}$
else if( ldq<max( 1_${ik}$, n ) ) then
info = -5_${ik}$
else if( cutpnt<min( 1_${ik}$, n ) .or. cutpnt>n ) then
info = -8_${ik}$
else if( ldq2<max( 1_${ik}$, n ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'ZLAED8', -info )
return
end if
! need to initialize givptr to o here in case of quick exit
! to prevent an unspecified code behavior (usually sigfault)
! when iwork array on entry to *stedc is not zeroed
! (or at least some iwork entries which used in *laed7 for givptr).
givptr = 0_${ik}$
! quick return if possible
if( n==0 )return
n1 = cutpnt
n2 = n - n1
n1p1 = n1 + 1_${ik}$
if( rho<zero ) then
call stdlib${ii}$_${c2ri(ci)}$scal( n2, mone, z( n1p1 ), 1_${ik}$ )
end if
! normalize z so that norm(z) = 1
t = one / sqrt( two )
do j = 1, n
indx( j ) = j
end do
call stdlib${ii}$_${c2ri(ci)}$scal( n, t, z, 1_${ik}$ )
rho = abs( two*rho )
! sort the eigenvalues into increasing order
do i = cutpnt + 1, n
indxq( i ) = indxq( i ) + cutpnt
end do
do i = 1, n
dlamda( i ) = d( indxq( i ) )
w( i ) = z( indxq( i ) )
end do
i = 1_${ik}$
j = cutpnt + 1_${ik}$
call stdlib${ii}$_${c2ri(ci)}$lamrg( n1, n2, dlamda, 1_${ik}$, 1_${ik}$, indx )
do i = 1, n
d( i ) = dlamda( indx( i ) )
z( i ) = w( indx( i ) )
end do
! calculate the allowable deflation tolerance
imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, z, 1_${ik}$ )
jmax = stdlib${ii}$_i${c2ri(ci)}$amax( n, d, 1_${ik}$ )
eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' )
tol = eight*eps*abs( d( jmax ) )
! if the rank-1 modifier is small enough, no more needs to be done
! -- except to reorganize q so that its columns correspond with the
! elements in d.
if( rho*abs( z( imax ) )<=tol ) then
k = 0_${ik}$
do j = 1, n
perm( j ) = indxq( indx( j ) )
call stdlib${ii}$_${ci}$copy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
call stdlib${ii}$_${ci}$lacpy( 'A', qsiz, n, q2( 1_${ik}$, 1_${ik}$ ), ldq2, q( 1_${ik}$, 1_${ik}$ ), ldq )
return
end if
! if there are multiple eigenvalues then the problem deflates. here
! the number of equal eigenvalues are found. as each equal
! eigenvalue is found, an elementary reflector is computed to rotate
! the corresponding eigensubspace so that the corresponding
! components of z are zero in this new basis.
k = 0_${ik}$
k2 = n + 1_${ik}$
do j = 1, n
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
if( j==n )go to 100
else
jlam = j
go to 70
end if
end do
70 continue
j = j + 1_${ik}$
if( j>n )go to 90
if( rho*abs( z( j ) )<=tol ) then
! deflate due to small z component.
k2 = k2 - 1_${ik}$
indxp( k2 ) = j
else
! check if eigenvalues are close enough to allow deflation.
s = z( jlam )
c = z( j )
! find sqrt(a**2+b**2) without overflow or
! destructive underflow.
tau = stdlib${ii}$_${c2ri(ci)}$lapy2( c, s )
t = d( j ) - d( jlam )
c = c / tau
s = -s / tau
if( abs( t*c*s )<=tol ) then
! deflation is possible.
z( j ) = tau
z( jlam ) = zero
! record the appropriate givens rotation
givptr = givptr + 1_${ik}$
givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) )
givcol( 2_${ik}$, givptr ) = indxq( indx( j ) )
givnum( 1_${ik}$, givptr ) = c
givnum( 2_${ik}$, givptr ) = s
call stdlib${ii}$_${ci}$drot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) &
) ), 1_${ik}$, c, s )
t = d( jlam )*c*c + d( j )*s*s
d( j ) = d( jlam )*s*s + d( j )*c*c
d( jlam ) = t
k2 = k2 - 1_${ik}$
i = 1_${ik}$
80 continue
if( k2+i<=n ) then
if( d( jlam )<d( indxp( k2+i ) ) ) then
indxp( k2+i-1 ) = indxp( k2+i )
indxp( k2+i ) = jlam
i = i + 1_${ik}$
go to 80
else
indxp( k2+i-1 ) = jlam
end if
else
indxp( k2+i-1 ) = jlam
end if
jlam = j
else
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
jlam = j
end if
end if
go to 70
90 continue
! record the last eigenvalue.
k = k + 1_${ik}$
w( k ) = z( jlam )
dlamda( k ) = d( jlam )
indxp( k ) = jlam
100 continue
! sort the eigenvalues and corresponding eigenvectors into dlamda
! and q2 respectively. the eigenvalues/vectors which were not
! deflated go into the first k slots of dlamda and q2 respectively,
! while those which were deflated go into the last n - k slots.
do j = 1, n
jp = indxp( j )
dlamda( j ) = d( jp )
perm( j ) = indxq( indx( jp ) )
call stdlib${ii}$_${ci}$copy( qsiz, q( 1_${ik}$, perm( j ) ), 1_${ik}$, q2( 1_${ik}$, j ), 1_${ik}$ )
end do
! the deflated eigenvalues and their corresponding vectors go back
! into the last n - k slots of d and q respectively.
if( k<n ) then
call stdlib${ii}$_${c2ri(ci)}$copy( n-k, dlamda( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacpy( 'A', qsiz, n-k, q2( 1_${ik}$, k+1 ), ldq2, q( 1_${ik}$, k+1 ),ldq )
end if
return
end subroutine stdlib${ii}$_${ci}$laed8
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, info )
!! SLAED9 finds the roots of the secular equation, as defined by the
!! values in D, Z, and RHO, between KSTART and KSTOP. It makes the
!! appropriate calls to SLAED4 and then stores the new matrix of
!! eigenvectors for use in calculating the next level of Z vectors.
! -- 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) :: k, kstart, kstop, ldq, lds, n
real(sp), intent(in) :: rho
! Array Arguments
real(sp), intent(out) :: d(*), q(ldq,*), s(lds,*)
real(sp), intent(inout) :: dlamda(*), w(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(sp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then
info = -2_${ik}$
else if( max( 1_${ik}$, kstop )<kstart .or. kstop>max( 1_${ik}$, k ) )then
info = -3_${ik}$
else if( n<k ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( lds<max( 1_${ik}$, k ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'SLAED9', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, n
dlamda( i ) = stdlib${ii}$_slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = kstart, kstop
call stdlib${ii}$_slaed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1_${ik}$ .or. k==2_${ik}$ ) then
do i = 1, k
do j = 1, k
s( j, i ) = q( j, i )
end do
end do
go to 120
end if
! compute updated w.
call stdlib${ii}$_scopy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_scopy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i, 1_${ik}$ ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
q( i, j ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_snrm2( k, q( 1_${ik}$, j ), 1_${ik}$ )
do i = 1, k
s( i, j ) = q( i, j ) / temp
end do
end do
120 continue
return
end subroutine stdlib${ii}$_slaed9
pure module subroutine stdlib${ii}$_dlaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, info )
!! DLAED9 finds the roots of the secular equation, as defined by the
!! values in D, Z, and RHO, between KSTART and KSTOP. It makes the
!! appropriate calls to DLAED4 and then stores the new matrix of
!! eigenvectors for use in calculating the next level of Z vectors.
! -- 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) :: k, kstart, kstop, ldq, lds, n
real(dp), intent(in) :: rho
! Array Arguments
real(dp), intent(out) :: d(*), q(ldq,*), s(lds,*)
real(dp), intent(inout) :: dlamda(*), w(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(dp) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then
info = -2_${ik}$
else if( max( 1_${ik}$, kstop )<kstart .or. kstop>max( 1_${ik}$, k ) )then
info = -3_${ik}$
else if( n<k ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( lds<max( 1_${ik}$, k ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED9', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, n
dlamda( i ) = stdlib${ii}$_dlamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = kstart, kstop
call stdlib${ii}$_dlaed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1_${ik}$ .or. k==2_${ik}$ ) then
do i = 1, k
do j = 1, k
s( j, i ) = q( j, i )
end do
end do
go to 120
end if
! compute updated w.
call stdlib${ii}$_dcopy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_dcopy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i, 1_${ik}$ ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
q( i, j ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_dnrm2( k, q( 1_${ik}$, j ), 1_${ik}$ )
do i = 1, k
s( i, j ) = q( i, j ) / temp
end do
end do
120 continue
return
end subroutine stdlib${ii}$_dlaed9
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$laed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, info )
!! DLAED9: finds the roots of the secular equation, as defined by the
!! values in D, Z, and RHO, between KSTART and KSTOP. It makes the
!! appropriate calls to DLAED4 and then stores the new matrix of
!! eigenvectors for use in calculating the next level of Z vectors.
! -- 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) :: k, kstart, kstop, ldq, lds, n
real(${rk}$), intent(in) :: rho
! Array Arguments
real(${rk}$), intent(out) :: d(*), q(ldq,*), s(lds,*)
real(${rk}$), intent(inout) :: dlamda(*), w(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j
real(${rk}$) :: temp
! Intrinsic Functions
! Executable Statements
! test the input parameters.
info = 0_${ik}$
if( k<0_${ik}$ ) then
info = -1_${ik}$
else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then
info = -2_${ik}$
else if( max( 1_${ik}$, kstop )<kstart .or. kstop>max( 1_${ik}$, k ) )then
info = -3_${ik}$
else if( n<k ) then
info = -4_${ik}$
else if( ldq<max( 1_${ik}$, k ) ) then
info = -7_${ik}$
else if( lds<max( 1_${ik}$, k ) ) then
info = -12_${ik}$
end if
if( info/=0_${ik}$ ) then
call stdlib${ii}$_xerbla( 'DLAED9', -info )
return
end if
! quick return if possible
if( k==0 )return
! modify values dlamda(i) to make sure all dlamda(i)-dlamda(j) can
! be computed with high relative accuracy (barring over/underflow).
! this is a problem on machines without a guard digit in
! add/subtract (cray xmp, cray ymp, cray c 90 and cray 2).
! the following code replaces dlamda(i) by 2*dlamda(i)-dlamda(i),
! which on any of these machines zeros out the bottommost
! bit of dlamda(i) if it is 1; this makes the subsequent
! subtractions dlamda(i)-dlamda(j) unproblematic when cancellation
! occurs. on binary machines with a guard digit (almost all
! machines) it does not change dlamda(i) at all. on hexadecimal
! and decimal machines with a guard digit, it slightly
! changes the bottommost bits of dlamda(i). it does not account
! for hexadecimal or decimal machines without guard digits
! (we know of none). we use a subroutine call to compute
! 2*dlambda(i) to prevent optimizing compilers from eliminating
! this code.
do i = 1, n
dlamda( i ) = stdlib${ii}$_${ri}$lamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
end do
do j = kstart, kstop
call stdlib${ii}$_${ri}$laed4( k, j, dlamda, w, q( 1_${ik}$, j ), rho, d( j ), info )
! if the zero finder fails, the computation is terminated.
if( info/=0 )go to 120
end do
if( k==1_${ik}$ .or. k==2_${ik}$ ) then
do i = 1, k
do j = 1, k
s( j, i ) = q( j, i )
end do
end do
go to 120
end if
! compute updated w.
call stdlib${ii}$_${ri}$copy( k, w, 1_${ik}$, s, 1_${ik}$ )
! initialize w(i) = q(i,i)
call stdlib${ii}$_${ri}$copy( k, q, ldq+1, w, 1_${ik}$ )
do j = 1, k
do i = 1, j - 1
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
do i = j + 1, k
w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
end do
end do
do i = 1, k
w( i ) = sign( sqrt( -w( i ) ), s( i, 1_${ik}$ ) )
end do
! compute eigenvectors of the modified rank-1 modification.
do j = 1, k
do i = 1, k
q( i, j ) = w( i ) / q( i, j )
end do
temp = stdlib${ii}$_${ri}$nrm2( k, q( 1_${ik}$, j ), 1_${ik}$ )
do i = 1, k
s( i, j ) = q( i, j ) / temp
end do
end do
120 continue
return
end subroutine stdlib${ii}$_${ri}$laed9
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_eigv_tridiag
