Other Auxiliary Routines

Topics
	double
	real
	complex
	complex16

Namespaces
module	la_constants
	LA_CONSTANTS is a module for the scaling constants for the compiled Fortran single and double precisions

Functions
subroutine	clartg (f, g, c, s, r)
	CLARTG generates a plane rotation with real cosine and complex sine.
subroutine	classq (n, x, incx, scl, sumsq)
	CLASSQ updates a sum of squares represented in scaled form.
logical function	disnan (din)
	DISNAN tests input for NaN.
subroutine	dlabad (small, large)
	DLABAD
subroutine	dlacpy (uplo, m, n, a, lda, b, ldb)
	DLACPY copies all or part of one two-dimensional array to another.
subroutine	dlae2 (a, b, c, rt1, rt2)
	DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
subroutine	dlaebz (ijob, nitmax, n, mmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, mout, nab, work, iwork, info)
	DLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz.
subroutine	dlaev2 (a, b, c, rt1, rt2, cs1, sn1)
	DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
subroutine	dlagts (job, n, a, b, c, d, in, y, tol, info)
	DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.
logical function	dlaisnan (din1, din2)
	DLAISNAN tests input for NaN by comparing two arguments for inequality.
integer function	dlaneg (n, d, lld, sigma, pivmin, r)
	DLANEG computes the Sturm count.
double precision function	dlanst (norm, n, d, e)
	DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
double precision function	dlapy2 (x, y)
	DLAPY2 returns sqrt(x2+y2).
double precision function	dlapy3 (x, y, z)
	DLAPY3 returns sqrt(x2+y2+z2).
subroutine	dlarnv (idist, iseed, n, x)
	DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine	dlarra (n, d, e, e2, spltol, tnrm, nsplit, isplit, info)
	DLARRA computes the splitting points with the specified threshold.
subroutine	dlarrb (n, d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, work, iwork, pivmin, spdiam, twist, info)
	DLARRB provides limited bisection to locate eigenvalues for more accuracy.
subroutine	dlarrc (jobt, n, vl, vu, d, e, pivmin, eigcnt, lcnt, rcnt, info)
	DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
subroutine	dlarrd (range, order, n, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, m, w, werr, wl, wu, iblock, indexw, work, iwork, info)
	DLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy.
subroutine	dlarre (range, n, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, work, iwork, info)
	DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.
subroutine	dlarrf (n, d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, sigma, dplus, lplus, work, info)
	DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated.
subroutine	dlarrj (n, d, e2, ifirst, ilast, rtol, offset, w, werr, work, iwork, pivmin, spdiam, info)
	DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
subroutine	dlarrk (n, iw, gl, gu, d, e2, pivmin, reltol, w, werr, info)
	DLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy.
subroutine	dlarrr (n, d, e, info)
	DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues.
subroutine	dlartg (f, g, c, s, r)
	DLARTG generates a plane rotation with real cosine and real sine.
subroutine	dlartgp (f, g, cs, sn, r)
	DLARTGP generates a plane rotation so that the diagonal is nonnegative.
subroutine	dlaruv (iseed, n, x)
	DLARUV returns a vector of n random real numbers from a uniform distribution.
subroutine	dlas2 (f, g, h, ssmin, ssmax)
	DLAS2 computes singular values of a 2-by-2 triangular matrix.
subroutine	dlascl (type, kl, ku, cfrom, cto, m, n, a, lda, info)
	DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine	dlasd0 (n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork, work, info)
	DLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	dlasd1 (nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt, idxq, iwork, work, info)
	DLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc.
subroutine	dlasd2 (nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt, ldvt, dsigma, u2, ldu2, vt2, ldvt2, idxp, idx, idxc, idxq, coltyp, info)
	DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc.
subroutine	dlasd3 (nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2, ldu2, vt, ldvt, vt2, ldvt2, idxc, ctot, z, info)
	DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc.
subroutine	dlasd4 (n, i, d, z, delta, rho, sigma, work, info)
	DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc.
subroutine	dlasd5 (i, d, z, delta, rho, dsigma, work)
	DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc.
subroutine	dlasd6 (icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, iwork, info)
	DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc.
subroutine	dlasd7 (icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl, vlw, alpha, beta, dsigma, idx, idxp, idxq, perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s, info)
	DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc.
subroutine	dlasd8 (icompq, k, d, z, vf, vl, difl, difr, lddifr, dsigma, work, info)
	DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc.
subroutine	dlasda (icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
	DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	dlasdq (uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
	DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	dlasdt (n, lvl, nd, inode, ndiml, ndimr, msub)
	DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
subroutine	dlaset (uplo, m, n, alpha, beta, a, lda)
	DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine	dlasr (side, pivot, direct, m, n, c, s, a, lda)
	DLASR applies a sequence of plane rotations to a general rectangular matrix.
subroutine	dlassq (n, x, incx, scl, sumsq)
	DLASSQ updates a sum of squares represented in scaled form.
subroutine	dlasv2 (f, g, h, ssmin, ssmax, snr, csr, snl, csl)
	DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
integer function	ieeeck (ispec, zero, one)
	IEEECK
integer function	iladlc (m, n, a, lda)
	ILADLC scans a matrix for its last non-zero column.
integer function	iladlr (m, n, a, lda)
	ILADLR scans a matrix for its last non-zero row.
integer function	ilaenv (ispec, name, opts, n1, n2, n3, n4)
	ILAENV
integer function	ilaenv2stage (ispec, name, opts, n1, n2, n3, n4)
	ILAENV2STAGE
integer function	iparmq (ispec, name, opts, n, ilo, ihi, lwork)
	IPARMQ
logical function	lsamen (n, ca, cb)
	LSAMEN
logical function	sisnan (sin)
	SISNAN tests input for NaN.
subroutine	slabad (small, large)
	SLABAD
subroutine	slacpy (uplo, m, n, a, lda, b, ldb)
	SLACPY copies all or part of one two-dimensional array to another.
subroutine	slae2 (a, b, c, rt1, rt2)
	SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
subroutine	slaebz (ijob, nitmax, n, mmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, mout, nab, work, iwork, info)
	SLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz.
subroutine	slaev2 (a, b, c, rt1, rt2, cs1, sn1)
	SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
subroutine	slag2d (m, n, sa, ldsa, a, lda, info)
	SLAG2D converts a single precision matrix to a double precision matrix.
subroutine	slagts (job, n, a, b, c, d, in, y, tol, info)
	SLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.
logical function	slaisnan (sin1, sin2)
	SLAISNAN tests input for NaN by comparing two arguments for inequality.
integer function	slaneg (n, d, lld, sigma, pivmin, r)
	SLANEG computes the Sturm count.
real function	slanst (norm, n, d, e)
	SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.
real function	slapy2 (x, y)
	SLAPY2 returns sqrt(x2+y2).
real function	slapy3 (x, y, z)
	SLAPY3 returns sqrt(x2+y2+z2).
subroutine	slarnv (idist, iseed, n, x)
	SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine	slarra (n, d, e, e2, spltol, tnrm, nsplit, isplit, info)
	SLARRA computes the splitting points with the specified threshold.
subroutine	slarrb (n, d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, work, iwork, pivmin, spdiam, twist, info)
	SLARRB provides limited bisection to locate eigenvalues for more accuracy.
subroutine	slarrc (jobt, n, vl, vu, d, e, pivmin, eigcnt, lcnt, rcnt, info)
	SLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.
subroutine	slarrd (range, order, n, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, m, w, werr, wl, wu, iblock, indexw, work, iwork, info)
	SLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy.
subroutine	slarre (range, n, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, work, iwork, info)
	SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.
subroutine	slarrf (n, d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, sigma, dplus, lplus, work, info)
	SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated.
subroutine	slarrj (n, d, e2, ifirst, ilast, rtol, offset, w, werr, work, iwork, pivmin, spdiam, info)
	SLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.
subroutine	slarrk (n, iw, gl, gu, d, e2, pivmin, reltol, w, werr, info)
	SLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy.
subroutine	slarrr (n, d, e, info)
	SLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues.
subroutine	slartg (f, g, c, s, r)
	SLARTG generates a plane rotation with real cosine and real sine.
subroutine	slartgp (f, g, cs, sn, r)
	SLARTGP generates a plane rotation so that the diagonal is nonnegative.
subroutine	slaruv (iseed, n, x)
	SLARUV returns a vector of n random real numbers from a uniform distribution.
subroutine	slas2 (f, g, h, ssmin, ssmax)
	SLAS2 computes singular values of a 2-by-2 triangular matrix.
subroutine	slascl (type, kl, ku, cfrom, cto, m, n, a, lda, info)
	SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine	slasd0 (n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork, work, info)
	SLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	slasd1 (nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt, idxq, iwork, work, info)
	SLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc.
subroutine	slasd2 (nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt, ldvt, dsigma, u2, ldu2, vt2, ldvt2, idxp, idx, idxc, idxq, coltyp, info)
	SLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc.
subroutine	slasd3 (nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2, ldu2, vt, ldvt, vt2, ldvt2, idxc, ctot, z, info)
	SLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc.
subroutine	slasd4 (n, i, d, z, delta, rho, sigma, work, info)
	SLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by sbdsdc.
subroutine	slasd5 (i, d, z, delta, rho, dsigma, work)
	SLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc.
subroutine	slasd6 (icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, perm, givptr, givcol, ldgcol, givnum, ldgnum, poles, difl, difr, z, k, c, s, work, iwork, info)
	SLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc.
subroutine	slasd7 (icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl, vlw, alpha, beta, dsigma, idx, idxp, idxq, perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s, info)
	SLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc.
subroutine	slasd8 (icompq, k, d, z, vf, vl, difl, difr, lddifr, dsigma, work, info)
	SLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc.
subroutine	slasda (icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k, difl, difr, z, poles, givptr, givcol, ldgcol, perm, givnum, c, s, work, iwork, info)
	SLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	slasdq (uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
	SLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
subroutine	slasdt (n, lvl, nd, inode, ndiml, ndimr, msub)
	SLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.
subroutine	slaset (uplo, m, n, alpha, beta, a, lda)
	SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine	slasr (side, pivot, direct, m, n, c, s, a, lda)
	SLASR applies a sequence of plane rotations to a general rectangular matrix.
subroutine	slassq (n, x, incx, scl, sumsq)
	SLASSQ updates a sum of squares represented in scaled form.
subroutine	slasv2 (f, g, h, ssmin, ssmax, snr, csr, snl, csl)
	SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
subroutine	xerbla (srname, info)
	XERBLA
subroutine	xerbla_array (srname_array, srname_len, info)
	XERBLA_ARRAY
subroutine	zlartg (f, g, c, s, r)
	ZLARTG generates a plane rotation with real cosine and complex sine.
subroutine	zlassq (n, x, incx, scl, sumsq)
	ZLASSQ updates a sum of squares represented in scaled form.

Detailed Description

This is the group of Other Auxiliary routines

Function Documentation

clartg()

subroutine clartg	(	complex(wp)	f,
		complex(wp)	g,
		real(wp)	c,
		complex(wp)	s,
		complex(wp)	r )

CLARTG generates a plane rotation with real cosine and complex sine.

Purpose:

!>
!> CLARTG generates a plane rotation so that
!>
!>    [  C         S  ] . [ F ]  =  [ R ]
!>    [ -conjg(S)  C  ]   [ G ]     [ 0 ]
!>
!> where C is real and C**2 + |S|**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>
!>    sgn(x) = {  x / |x|,   x != 0
!>             {  1,         x = 0
!>
!>    R = sgn(F) * sqrt(|F|**2 + |G|**2)
!>
!>    C = |F| / sqrt(|F|**2 + |G|**2)
!>
!>    S = sgn(F) * conjg(G) / sqrt(|F|**2 + |G|**2)
!>
!> When F and G are real, the formulas simplify to C = F/R and
!> S = G/R, and the returned values of C, S, and R should be
!> identical to those returned by CLARTG.
!>
!> The algorithm used to compute these quantities incorporates scaling
!> to avoid overflow or underflow in computing the square root of the
!> sum of squares.
!>
!> This is a faster version of the BLAS1 routine CROTG, except for
!> the following differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0, then C=0 and S is chosen so that R is real.
!>
!> Below, wp=>sp stands for single precision from LA_CONSTANTS module.
!> 

Parameters

[in]	F	!> F is COMPLEX(wp) !> The first component of vector to be rotated. !>
[in]	G	!> G is COMPLEX(wp) !> The second component of vector to be rotated. !>
[out]	C	!> C is REAL(wp) !> The cosine of the rotation. !>
[out]	S	!> S is COMPLEX(wp) !> The sine of the rotation. !>
[out]	R	!> R is COMPLEX(wp) !> The nonzero component of the rotated vector. !>

Author

Edward Anderson, Lockheed Martin

Date

August 2016

Contributors:

Weslley Pereira, University of Colorado Denver, USA

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> 

Definition at line 117 of file clartg.f90.

   use la_constants, &
   only: wp=>sp, zero=>szero, one=>sone, two=>stwo, czero, &
         rtmin=>srtmin, rtmax=>srtmax, safmin=>ssafmin, safmax=>ssafmax
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp)           c
   complex(wp)        f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
   complex(wp) :: fs, gs, t
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, aimag, conjg, max, min, real, sqrt
!  ..
!  .. Statement Functions ..
   real(wp) :: ABSSQ
!  ..
!  .. Statement Function definitions ..
   abssq( t ) = real( t )**2 + aimag( t )**2
!  ..
!  .. Executable Statements ..
!
   if( g == czero ) then
      c = one
      s = czero
      r = f
   else if( f == czero ) then
      c = zero
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         g2 = abssq( g )
         d = sqrt( g2 )
         s = conjg( g ) / d
         r = d
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = abssq( gs )
         d = sqrt( g2 )
         s = conjg( gs ) / d
         r = d*u
      end if
   else
      f1 = max( abs(real(f)), abs(aimag(f)) )
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( f1 > rtmin .and. f1 < rtmax .and. &
          g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         f2 = abssq( f )
         g2 = abssq( g )
         h2 = f2 + g2
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = f2*p
         s = conjg( g )*( f*p )
         r = f*( h2*p )
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, f1, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = abssq( gs )
         if( f1*uu < rtmin ) then
!
!           f is not well-scaled when scaled by g1.
!           Use a different scaling for f.
!
            v = min( safmax, max( safmin, f1 ) )
            vv = one / v
            w = v * uu
            fs = f*vv
            f2 = abssq( fs )
            h2 = f2*w**2 + g2
         else
!
!           Otherwise use the same scaling for f and g.
!
            w = one
            fs = f*uu
            f2 = abssq( fs )
            h2 = f2 + g2
         end if
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = ( f2*p )*w
         s = conjg( gs )*( fs*p )
         r = ( fs*( h2*p ) )*u
      end if
   end if
   return

classq()

subroutine classq	(	integer	n,
		complex(wp), dimension(*)	x,
		integer	incx,
		real(wp)	scl,
		real(wp)	sumsq )

CLASSQ updates a sum of squares represented in scaled form.

Download CLASSQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> CLASSQ  returns the values  scl  and  smsq  such that
!>
!>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!>
!> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!>    we require:   scale >= sqrt( TINY*EPS ) / sbig   on entry,
!> and if 0 < scale * sqrt( sumsq ) < tsml then
!>    we require:   scale <= sqrt( HUGE ) / ssml       on entry,
!> where
!>    tbig -- upper threshold for values whose square is representable;
!>    sbig -- scaling constant for big numbers; \see la_constants.f90
!>    tsml -- lower threshold for values whose square is representable;
!>    ssml -- scaling constant for small numbers; \see la_constants.f90
!> and
!>    TINY*EPS -- tiniest representable number;
!>    HUGE     -- biggest representable number.
!>
!> 

Parameters

[in]	N	!> N is INTEGER !> The number of elements to be used from the vector x. !>
[in]	X	!> X is COMPLEX array, dimension (1+(N-1)*abs(INCX)) !> The vector for which a scaled sum of squares is computed. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !>
[in]	INCX	!> INCX is INTEGER !> The increment between successive values of the vector x. !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX = 0, x isn't a vector so there is no need to call !> this subroutine. If you call it anyway, it will count x(1) !> in the vector norm N times. !>
[in,out]	SCALE	!> SCALE is REAL !> On entry, the value scale in the equation above. !> On exit, SCALE is overwritten with scl , the scaling factor !> for the sum of squares. !>
[in,out]	SUMSQ	!> SUMSQ is REAL !> On entry, the value sumsq in the equation above. !> On exit, SUMSQ is overwritten with smsq , the basic sum of !> squares from which scl has been factored out. !>

Author

Edward Anderson, Lockheed Martin

Contributors:

Weslley Pereira, University of Colorado Denver, USA Nick Papior, Technical University of Denmark, DK

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> 

Definition at line 136 of file classq.f90.

   use la_constants, &
      only: wp=>sp, zero=>szero, one=>sone, &
            sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
   use la_xisnan
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Scalar Arguments ..
   integer :: incx, n
   real(wp) :: scl, sumsq
!  ..
!  .. Array Arguments ..
   complex(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, ymax, ymin
!  ..
!
!  Quick return if possible
!
   if( la_isnan(scl) .or. la_isnan(sumsq) ) return
   if( sumsq == zero ) scl = one
   if( scl == zero ) then
      scl = one
      sumsq = zero
   end if
   if (n <= 0) then
      return
   end if
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(real(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ax = abs(aimag(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Put the existing sum of squares into one of the accumulators
!
   if( sumsq > zero ) then
      ax = scl*sqrt( sumsq )
      if (ax > tbig) then
!        We assume scl >= sqrt( TINY*EPS ) / sbig
         abig = abig + (scl*sbig)**2 * sumsq
      else if (ax < tsml) then
!        We assume scl <= sqrt( HUGE ) / ssml
         if (notbig) asml = asml + (scl*ssml)**2 * sumsq
      else
         amed = amed + scl**2 * sumsq
      end if
   end if
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range or zero
!
      scl = one
      sumsq = amed
   end if
   return

disnan()

logical function disnan

(

double precision, intent(in)

din

)

DISNAN tests input for NaN.

Download DISNAN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
!> otherwise.  To be replaced by the Fortran 2003 intrinsic in the
!> future.
!> 

Parameters

[in]

DIN

!> DIN is DOUBLE PRECISION !> Input to test for NaN. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 58 of file disnan.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION, INTENT(IN) :: DIN
*     ..
*
*  =====================================================================
*
*  .. External Functions ..
      LOGICAL DLAISNAN
      EXTERNAL dlaisnan
*  ..
*  .. Executable Statements ..
      disnan = dlaisnan(din,din)
      RETURN

dlabad()

subroutine dlabad	(	double precision	small,
		double precision	large )

DLABAD

Download DLABAD + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLABAD takes as input the values computed by DLAMCH for underflow and
!> overflow, and returns the square root of each of these values if the
!> log of LARGE is sufficiently large.  This subroutine is intended to
!> identify machines with a large exponent range, such as the Crays, and
!> redefine the underflow and overflow limits to be the square roots of
!> the values computed by DLAMCH.  This subroutine is needed because
!> DLAMCH does not compensate for poor arithmetic in the upper half of
!> the exponent range, as is found on a Cray.
!> 

Parameters

[in,out]	SMALL	!> SMALL is DOUBLE PRECISION !> On entry, the underflow threshold as computed by DLAMCH. !> On exit, if LOG10(LARGE) is sufficiently large, the square !> root of SMALL, otherwise unchanged. !>
[in,out]	LARGE	!> LARGE is DOUBLE PRECISION !> On entry, the overflow threshold as computed by DLAMCH. !> On exit, if LOG10(LARGE) is sufficiently large, the square !> root of LARGE, otherwise unchanged. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 73 of file dlabad.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   LARGE, SMALL
*     ..
*
*  =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          log10, sqrt
*     ..
*     .. Executable Statements ..
*
*     If it looks like we're on a Cray, take the square root of
*     SMALL and LARGE to avoid overflow and underflow problems.
*
      IF( log10( large ).GT.2000.d0 ) THEN
         small = sqrt( small )
         large = sqrt( large )
      END IF
*
      RETURN
*
*     End of DLABAD
*

dlacpy()

subroutine dlacpy	(	character	uplo,
		integer	m,
		integer	n,
		double precision, dimension( lda, * )	a,
		integer	lda,
		double precision, dimension( ldb, * )	b,
		integer	ldb )

DLACPY copies all or part of one two-dimensional array to another.

Download DLACPY + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLACPY copies all or part of a two-dimensional matrix A to another
!> matrix B.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be copied to B. !> = 'U': Upper triangular part !> = 'L': Lower triangular part !> Otherwise: All of the matrix A !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. If UPLO = 'U', only the upper triangle !> or trapezoid is accessed; if UPLO = 'L', only the lower !> triangle or trapezoid is accessed. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>
[out]	B	!> B is DOUBLE PRECISION array, dimension (LDB,N) !> On exit, B = A in the locations specified by UPLO. !>
[in]	LDB	!> LDB is INTEGER !> The leading dimension of the array B. LDB >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 102 of file dlacpy.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDB, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( lsame( uplo, 'U' ) ) THEN
         DO 20 j = 1, n
            DO 10 i = 1, min( j, m )
               b( i, j ) = a( i, j )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( lsame( uplo, 'L' ) ) THEN
         DO 40 j = 1, n
            DO 30 i = j, m
               b( i, j ) = a( i, j )
   30       CONTINUE
   40    CONTINUE
      ELSE
         DO 60 j = 1, n
            DO 50 i = 1, m
               b( i, j ) = a( i, j )
   50       CONTINUE
   60    CONTINUE
      END IF
      RETURN
*
*     End of DLACPY
*

dlae2()

subroutine dlae2	(	double precision	a,
		double precision	b,
		double precision	c,
		double precision	rt1,
		double precision	rt2 )

DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.

Download DLAE2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, and RT2
!> is the eigenvalue of smaller absolute value.
!> 

Parameters

[in]	A	!> A is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !>
[in]	B	!> B is DOUBLE PRECISION !> The (1,2) and (2,1) elements of the 2-by-2 matrix. !>
[in]	C	!> C is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !>
[out]	RT1	!> RT1 is DOUBLE PRECISION !> The eigenvalue of larger absolute value. !>
[out]	RT2	!> RT2 is DOUBLE PRECISION !> The eigenvalue of smaller absolute value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> 

Definition at line 101 of file dlae2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, RT1, RT2
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   HALF
      parameter( half = 0.5d0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   AB, ACMN, ACMX, ADF, DF, RT, SM, TB
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
*     Compute the eigenvalues
*
      sm = a + c
      df = a - c
      adf = abs( df )
      tb = b + b
      ab = abs( tb )
      IF( abs( a ).GT.abs( c ) ) THEN
         acmx = a
         acmn = c
      ELSE
         acmx = c
         acmn = a
      END IF
      IF( adf.GT.ab ) THEN
         rt = adf*sqrt( one+( ab / adf )**2 )
      ELSE IF( adf.LT.ab ) THEN
         rt = ab*sqrt( one+( adf / ab )**2 )
      ELSE
*
*        Includes case AB=ADF=0
*
         rt = ab*sqrt( two )
      END IF
      IF( sm.LT.zero ) THEN
         rt1 = half*( sm-rt )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE IF( sm.GT.zero ) THEN
         rt1 = half*( sm+rt )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE
*
*        Includes case RT1 = RT2 = 0
*
         rt1 = half*rt
         rt2 = -half*rt
      END IF
      RETURN
*
*     End of DLAE2
*

dlaebz()

subroutine dlaebz	(	integer	ijob,
		integer	nitmax,
		integer	n,
		integer	mmax,
		integer	minp,
		integer	nbmin,
		double precision	abstol,
		double precision	reltol,
		double precision	pivmin,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( * )	e2,
		integer, dimension( * )	nval,
		double precision, dimension( mmax, * )	ab,
		double precision, dimension( * )	c,
		integer	mout,
		integer, dimension( mmax, * )	nab,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

DLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz.

Download DLAEBZ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> 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 , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966
!>
!> Note: the arguments are, in general, *not* checked for unreasonable
!> values.
!> 

Parameters

[in]	IJOB	!> IJOB is INTEGER !> Specifies what is to be done: !> = 1: Compute NAB for the initial intervals. !> = 2: Perform bisection iteration to find eigenvalues of T. !> = 3: Perform bisection iteration to invert N(w), i.e., !> to find a point which has a specified number of !> eigenvalues of T to its left. !> Other values will cause DLAEBZ to return with INFO=-1. !>
[in]	NITMAX	!> NITMAX is INTEGER !> The maximum number of of bisection to be !> performed, i.e., an interval of width W will not be made !> smaller than 2^(-NITMAX) * W. If not all intervals !> have converged after NITMAX iterations, then INFO is set !> to the number of non-converged intervals. !>
[in]	N	!> N is INTEGER !> The dimension n of the tridiagonal matrix T. It must be at !> least 1. !>
[in]	MMAX	!> MMAX is INTEGER !> The maximum number of intervals. If more than MMAX intervals !> are generated, then DLAEBZ will quit with INFO=MMAX+1. !>
[in]	MINP	!> MINP is INTEGER !> The initial number of intervals. It may not be greater than !> MMAX. !>
[in]	NBMIN	!> NBMIN is INTEGER !> The smallest number of intervals that should be processed !> using a vector loop. If zero, then only the scalar loop !> will be used. !>
[in]	ABSTOL	!> ABSTOL is DOUBLE PRECISION !> The minimum (absolute) width of an interval. When an !> interval is narrower than ABSTOL, or than RELTOL times the !> larger (in magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. This must be at least !> zero. !>
[in]	RELTOL	!> RELTOL is DOUBLE PRECISION !> The minimum relative width of an interval. When an interval !> is narrower than ABSTOL, or than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum absolute value of a in the Sturm !> sequence loop. !> This must be at least max |e(j)**2|*safe_min and at !> least safe_min, where safe_min is at least !> the smallest number that can divide one without overflow. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The diagonal elements of the tridiagonal matrix T. !>
[in]	E	!> E is DOUBLE PRECISION array, dimension (N) !> The offdiagonal elements of the tridiagonal matrix T in !> positions 1 through N-1. E(N) is arbitrary. !>
[in]	E2	!> E2 is DOUBLE PRECISION array, dimension (N) !> The squares of the offdiagonal elements of the tridiagonal !> matrix T. E2(N) is ignored. !>
[in,out]	NVAL	!> NVAL is INTEGER array, dimension (MINP) !> If IJOB=1 or 2, not referenced. !> If IJOB=3, the desired values of N(w). The elements of NVAL !> will be reordered to correspond with the intervals in AB. !> Thus, NVAL(j) on output will not, in general be the same as !> NVAL(j) on input, but it will correspond with the interval !> (AB(j,1),AB(j,2)] on output. !>
[in,out]	AB	!> AB is DOUBLE PRECISION array, dimension (MMAX,2) !> The endpoints of the intervals. AB(j,1) is a(j), the left !> endpoint of the j-th interval, and AB(j,2) is b(j), the !> right endpoint of the j-th interval. The input intervals !> will, in general, be modified, split, and reordered by the !> calculation. !>
[in,out]	C	!> C is DOUBLE PRECISION array, dimension (MMAX) !> If IJOB=1, ignored. !> If IJOB=2, workspace. !> If IJOB=3, then on input C(j) should be initialized to the !> first search point in the binary search. !>
[out]	MOUT	!> MOUT is INTEGER !> If IJOB=1, the number of eigenvalues in the intervals. !> If IJOB=2 or 3, the number of intervals output. !> If IJOB=3, MOUT will equal MINP. !>
[in,out]	NAB	!> NAB is INTEGER array, dimension (MMAX,2) !> If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). !> If IJOB=2, then on input, NAB(i,j) should be set. It must !> satisfy the condition: !> N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), !> which means that in interval i only eigenvalues !> NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, !> NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with !> IJOB=1. !> On output, NAB(i,j) will contain !> max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of !> the input interval that the output interval !> (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the !> the input values of NAB(k,1) and NAB(k,2). !> If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), !> unless N(w) > NVAL(i) for all search points w , in which !> case NAB(i,1) will not be modified, i.e., the output !> value will be the same as the input value (modulo !> reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) !> for all search points w , in which case NAB(i,2) will !> not be modified. Normally, NAB should be set to some !> distinctive value(s) before DLAEBZ is called. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (MMAX) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (MMAX) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> = 0: All intervals converged. !> = 1--MMAX: The last INFO intervals did not converge. !> = MMAX+1: More than MMAX intervals were generated. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>      This routine is intended to be called only by other LAPACK
!>  routines, thus the interface is less user-friendly.  It is intended
!>  for two purposes:
!>
!>  (a) finding eigenvalues.  In this case, DLAEBZ should have one or
!>      more initial intervals set up in AB, and DLAEBZ should be called
!>      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
!>      Intervals with no eigenvalues would usually be thrown out at
!>      this point.  Also, if not all the eigenvalues in an interval i
!>      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
!>      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
!>      eigenvalue.  DLAEBZ is then called with IJOB=2 and MMAX
!>      no smaller than the value of MOUT returned by the call with
!>      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
!>      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
!>      tolerance specified by ABSTOL and RELTOL.
!>
!>  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
!>      In this case, start with a Gershgorin interval  (a,b).  Set up
!>      AB to contain 2 search intervals, both initially (a,b).  One
!>      NVAL element should contain  f-1  and the other should contain  l
!>      , while C should contain a and b, resp.  NAB(i,1) should be -1
!>      and NAB(i,2) should be N+1, to flag an error if the desired
!>      interval does not lie in (a,b).  DLAEBZ is then called with
!>      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
!>      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
!>      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
!>      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
!>      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
!>      w(l-r)=...=w(l+k) are handled similarly.
!> 

Definition at line 316 of file dlaebz.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
      DOUBLE PRECISION   ABSTOL, PIVMIN, RELTOL
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
      DOUBLE PRECISION   AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO, HALF
      parameter( zero = 0.0d0, two = 2.0d0,
     $                   half = 1.0d0 / two )
*     ..
*     .. Local Scalars ..
      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
     $                   KLNEW
      DOUBLE PRECISION   TMP1, TMP2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. Executable Statements ..
*
*     Check for Errors
*
      info = 0
      IF( ijob.LT.1 .OR. ijob.GT.3 ) THEN
         info = -1
         RETURN
      END IF
*
*     Initialize NAB
*
      IF( ijob.EQ.1 ) THEN
*
*        Compute the number of eigenvalues in the initial intervals.
*
         mout = 0
         DO 30 ji = 1, minp
            DO 20 jp = 1, 2
               tmp1 = d( 1 ) - ab( ji, jp )
               IF( abs( tmp1 ).LT.pivmin )
     $            tmp1 = -pivmin
               nab( ji, jp ) = 0
               IF( tmp1.LE.zero )
     $            nab( ji, jp ) = 1
*
               DO 10 j = 2, n
                  tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp )
                  IF( abs( tmp1 ).LT.pivmin )
     $               tmp1 = -pivmin
                  IF( tmp1.LE.zero )
     $               nab( ji, jp ) = nab( ji, jp ) + 1
   10          CONTINUE
   20       CONTINUE
            mout = mout + nab( ji, 2 ) - nab( ji, 1 )
   30    CONTINUE
         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
      kl = minp
*
*     If IJOB=2, initialize C.
*     If IJOB=3, use the user-supplied starting point.
*
      IF( ijob.EQ.2 ) THEN
         DO 40 ji = 1, minp
            c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) )
   40    CONTINUE
      END IF
*
*     Iteration loop
*
      DO 130 jit = 1, nitmax
*
*        Loop over intervals
*
         IF( kl-kf+1.GE.nbmin .AND. nbmin.GT.0 ) THEN
*
*           Begin of Parallel Version of the loop
*
            DO 60 ji = kf, kl
*
*              Compute N(c), the number of eigenvalues less than c
*
               work( ji ) = d( 1 ) - c( ji )
               iwork( ji ) = 0
               IF( work( ji ).LE.pivmin ) THEN
                  iwork( ji ) = 1
                  work( ji ) = min( work( ji ), -pivmin )
               END IF
*
               DO 50 j = 2, n
                  work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji )
                  IF( work( ji ).LE.pivmin ) THEN
                     iwork( ji ) = iwork( ji ) + 1
                     work( ji ) = min( work( ji ), -pivmin )
                  END IF
   50          CONTINUE
   60       CONTINUE
*
            IF( ijob.LE.2 ) THEN
*
*              IJOB=2: Choose all intervals containing eigenvalues.
*
               klnew = kl
               DO 70 ji = kf, kl
*
*                 Insure that N(w) is monotone
*
                  iwork( ji ) = min( nab( ji, 2 ),
     $                          max( nab( ji, 1 ), iwork( ji ) ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( iwork( ji ).EQ.nab( ji, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     ab( ji, 2 ) = c( ji )
*
                  ELSE IF( iwork( ji ).EQ.nab( ji, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     ab( ji, 1 ) = c( ji )
                  ELSE
                     klnew = klnew + 1
                     IF( klnew.LE.mmax ) THEN
*
*                       Eigenvalue in both intervals -- add upper to
*                       queue.
*
                        ab( klnew, 2 ) = ab( ji, 2 )
                        nab( klnew, 2 ) = nab( ji, 2 )
                        ab( klnew, 1 ) = c( ji )
                        nab( klnew, 1 ) = iwork( ji )
                        ab( ji, 2 ) = c( ji )
                        nab( ji, 2 ) = iwork( ji )
                     ELSE
                        info = mmax + 1
                     END IF
                  END IF
   70          CONTINUE
               IF( info.NE.0 )
     $            RETURN
               kl = klnew
            ELSE
*
*              IJOB=3: Binary search.  Keep only the interval containing
*                      w   s.t. N(w) = NVAL
*
               DO 80 ji = kf, kl
                  IF( iwork( ji ).LE.nval( ji ) ) THEN
                     ab( ji, 1 ) = c( ji )
                     nab( ji, 1 ) = iwork( ji )
                  END IF
                  IF( iwork( ji ).GE.nval( ji ) ) THEN
                     ab( ji, 2 ) = c( ji )
                     nab( ji, 2 ) = iwork( ji )
                  END IF
   80          CONTINUE
            END IF
*
         ELSE
*
*           End of Parallel Version of the loop
*
*           Begin of Serial Version of the loop
*
            klnew = kl
            DO 100 ji = kf, kl
*
*              Compute N(w), the number of eigenvalues less than w
*
               tmp1 = c( ji )
               tmp2 = d( 1 ) - tmp1
               itmp1 = 0
               IF( tmp2.LE.pivmin ) THEN
                  itmp1 = 1
                  tmp2 = min( tmp2, -pivmin )
               END IF
*
               DO 90 j = 2, n
                  tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1
                  IF( tmp2.LE.pivmin ) THEN
                     itmp1 = itmp1 + 1
                     tmp2 = min( tmp2, -pivmin )
                  END IF
   90          CONTINUE
*
               IF( ijob.LE.2 ) THEN
*
*                 IJOB=2: Choose all intervals containing eigenvalues.
*
*                 Insure that N(w) is monotone
*
                  itmp1 = min( nab( ji, 2 ),
     $                    max( nab( ji, 1 ), itmp1 ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( itmp1.EQ.nab( ji, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     ab( ji, 2 ) = tmp1
*
                  ELSE IF( itmp1.EQ.nab( ji, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     ab( ji, 1 ) = tmp1
                  ELSE IF( klnew.LT.mmax ) THEN
*
*                    Eigenvalue in both intervals -- add upper to queue.
*
                     klnew = klnew + 1
                     ab( klnew, 2 ) = ab( ji, 2 )
                     nab( klnew, 2 ) = nab( ji, 2 )
                     ab( klnew, 1 ) = tmp1
                     nab( klnew, 1 ) = itmp1
                     ab( ji, 2 ) = tmp1
                     nab( ji, 2 ) = itmp1
                  ELSE
                     info = mmax + 1
                     RETURN
                  END IF
               ELSE
*
*                 IJOB=3: Binary search.  Keep only the interval
*                         containing  w  s.t. N(w) = NVAL
*
                  IF( itmp1.LE.nval( ji ) ) THEN
                     ab( ji, 1 ) = tmp1
                     nab( ji, 1 ) = itmp1
                  END IF
                  IF( itmp1.GE.nval( ji ) ) THEN
                     ab( ji, 2 ) = tmp1
                     nab( ji, 2 ) = itmp1
                  END IF
               END IF
  100       CONTINUE
            kl = klnew
*
         END IF
*
*        Check for convergence
*
         kfnew = kf
         DO 110 ji = kf, kl
            tmp1 = abs( ab( ji, 2 )-ab( ji, 1 ) )
            tmp2 = max( abs( ab( ji, 2 ) ), abs( ab( ji, 1 ) ) )
            IF( tmp1.LT.max( abstol, pivmin, reltol*tmp2 ) .OR.
     $          nab( ji, 1 ).GE.nab( ji, 2 ) ) THEN
*
*              Converged -- Swap with position KFNEW,
*                           then increment KFNEW
*
               IF( ji.GT.kfnew ) THEN
                  tmp1 = ab( ji, 1 )
                  tmp2 = ab( ji, 2 )
                  itmp1 = nab( ji, 1 )
                  itmp2 = nab( ji, 2 )
                  ab( ji, 1 ) = ab( kfnew, 1 )
                  ab( ji, 2 ) = ab( kfnew, 2 )
                  nab( ji, 1 ) = nab( kfnew, 1 )
                  nab( ji, 2 ) = nab( kfnew, 2 )
                  ab( kfnew, 1 ) = tmp1
                  ab( kfnew, 2 ) = tmp2
                  nab( kfnew, 1 ) = itmp1
                  nab( kfnew, 2 ) = itmp2
                  IF( ijob.EQ.3 ) THEN
                     itmp1 = nval( ji )
                     nval( ji ) = nval( kfnew )
                     nval( kfnew ) = itmp1
                  END IF
               END IF
               kfnew = kfnew + 1
            END IF
  110    CONTINUE
         kf = kfnew
*
*        Choose Midpoints
*
         DO 120 ji = kf, kl
            c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) )
  120    CONTINUE
*
*        If no more intervals to refine, quit.
*
         IF( kf.GT.kl )
     $      GO TO 140
  130 CONTINUE
*
*     Converged
*
  140 CONTINUE
      info = max( kl+1-kf, 0 )
      mout = kl
*
      RETURN
*
*     End of DLAEBZ
*

dlaev2()

subroutine dlaev2	(	double precision	a,
		double precision	b,
		double precision	c,
		double precision	rt1,
		double precision	rt2,
		double precision	cs1,
		double precision	sn1 )

DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.

Download DLAEV2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
!> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
!> eigenvector for RT1, giving the decomposition
!>
!>    [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
!>    [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
!> 

Parameters

[in]	A	!> A is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !>
[in]	B	!> B is DOUBLE PRECISION !> The (1,2) element and the conjugate of the (2,1) element of !> the 2-by-2 matrix. !>
[in]	C	!> C is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !>
[out]	RT1	!> RT1 is DOUBLE PRECISION !> The eigenvalue of larger absolute value. !>
[out]	RT2	!> RT2 is DOUBLE PRECISION !> The eigenvalue of smaller absolute value. !>
[out]	CS1	!> CS1 is DOUBLE PRECISION !>
[out]	SN1	!> SN1 is DOUBLE PRECISION !> The vector (CS1, SN1) is a unit right eigenvector for RT1. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> 

Definition at line 119 of file dlaev2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, CS1, RT1, RT2, SN1
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   HALF
      parameter( half = 0.5d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            SGN1, SGN2
      DOUBLE PRECISION   AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
     $                   TB, TN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
*     Compute the eigenvalues
*
      sm = a + c
      df = a - c
      adf = abs( df )
      tb = b + b
      ab = abs( tb )
      IF( abs( a ).GT.abs( c ) ) THEN
         acmx = a
         acmn = c
      ELSE
         acmx = c
         acmn = a
      END IF
      IF( adf.GT.ab ) THEN
         rt = adf*sqrt( one+( ab / adf )**2 )
      ELSE IF( adf.LT.ab ) THEN
         rt = ab*sqrt( one+( adf / ab )**2 )
      ELSE
*
*        Includes case AB=ADF=0
*
         rt = ab*sqrt( two )
      END IF
      IF( sm.LT.zero ) THEN
         rt1 = half*( sm-rt )
         sgn1 = -1
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE IF( sm.GT.zero ) THEN
         rt1 = half*( sm+rt )
         sgn1 = 1
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE
*
*        Includes case RT1 = RT2 = 0
*
         rt1 = half*rt
         rt2 = -half*rt
         sgn1 = 1
      END IF
*
*     Compute the eigenvector
*
      IF( df.GE.zero ) THEN
         cs = df + rt
         sgn2 = 1
      ELSE
         cs = df - rt
         sgn2 = -1
      END IF
      acs = abs( cs )
      IF( acs.GT.ab ) THEN
         ct = -tb / cs
         sn1 = one / sqrt( one+ct*ct )
         cs1 = ct*sn1
      ELSE
         IF( ab.EQ.zero ) THEN
            cs1 = one
            sn1 = zero
         ELSE
            tn = -cs / tb
            cs1 = one / sqrt( one+tn*tn )
            sn1 = tn*cs1
         END IF
      END IF
      IF( sgn1.EQ.sgn2 ) THEN
         tn = cs1
         cs1 = -sn1
         sn1 = tn
      END IF
      RETURN
*
*     End of DLAEV2
*

dlagts()

subroutine dlagts	(	integer	job,
		integer	n,
		double precision, dimension( * )	a,
		double precision, dimension( * )	b,
		double precision, dimension( * )	c,
		double precision, dimension( * )	d,
		integer, dimension( * )	in,
		double precision, dimension( * )	y,
		double precision	tol,
		integer	info )

DLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.

Download DLAGTS + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAGTS may be used to solve one of the systems of equations
!>
!>    (T - lambda*I)*x = y   or   (T - lambda*I)**T*x = y,
!>
!> where T is an n by n tridiagonal matrix, for x, following the
!> factorization of (T - lambda*I) as
!>
!>    (T - lambda*I) = P*L*U ,
!>
!> by routine DLAGTF. The choice of equation to be solved is
!> controlled by the argument JOB, and in each case there is an option
!> to perturb zero or very small diagonal elements of U, this option
!> being intended for use in applications such as inverse iteration.
!> 

Parameters

[in]	JOB	!> JOB is INTEGER !> Specifies the job to be performed by DLAGTS as follows: !> = 1: The equations (T - lambda*I)x = y are to be solved, !> but diagonal elements of U are not to be perturbed. !> = -1: The equations (T - lambda*I)x = y are to be solved !> and, if overflow would otherwise occur, the diagonal !> elements of U are to be perturbed. See argument TOL !> below. !> = 2: The equations (T - lambda*I)**Tx = y are to be solved, !> but diagonal elements of U are not to be perturbed. !> = -2: The equations (T - lambda*I)**Tx = y are to be solved !> and, if overflow would otherwise occur, the diagonal !> elements of U are to be perturbed. See argument TOL !> below. !>
[in]	N	!> N is INTEGER !> The order of the matrix T. !>
[in]	A	!> A is DOUBLE PRECISION array, dimension (N) !> On entry, A must contain the diagonal elements of U as !> returned from DLAGTF. !>
[in]	B	!> B is DOUBLE PRECISION array, dimension (N-1) !> On entry, B must contain the first super-diagonal elements of !> U as returned from DLAGTF. !>
[in]	C	!> C is DOUBLE PRECISION array, dimension (N-1) !> On entry, C must contain the sub-diagonal elements of L as !> returned from DLAGTF. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N-2) !> On entry, D must contain the second super-diagonal elements !> of U as returned from DLAGTF. !>
[in]	IN	!> IN is INTEGER array, dimension (N) !> On entry, IN must contain details of the matrix P as returned !> from DLAGTF. !>
[in,out]	Y	!> Y is DOUBLE PRECISION array, dimension (N) !> On entry, the right hand side vector y. !> On exit, Y is overwritten by the solution vector x. !>
[in,out]	TOL	!> TOL is DOUBLE PRECISION !> On entry, with JOB < 0, TOL should be the minimum !> perturbation to be made to very small diagonal elements of U. !> TOL should normally be chosen as about eps*norm(U), where eps !> is the relative machine precision, but if TOL is supplied as !> non-positive, then it is reset to eps*max( abs( u(i,j) ) ). !> If JOB > 0 then TOL is not referenced. !> !> On exit, TOL is changed as described above, only if TOL is !> non-positive on entry. Otherwise TOL is unchanged. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: overflow would occur when computing the INFO(th) !> element of the solution vector x. This can only occur !> when JOB is supplied as positive and either means !> that a diagonal element of U is very small, or that !> the elements of the right-hand side vector y are very !> large. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 160 of file dlagts.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, JOB, N
      DOUBLE PRECISION   TOL
*     ..
*     .. Array Arguments ..
      INTEGER            IN( * )
      DOUBLE PRECISION   A( * ), B( * ), C( * ), D( * ), Y( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            K
      DOUBLE PRECISION   ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sign
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Executable Statements ..
*
      info = 0
      IF( ( abs( job ).GT.2 ) .OR. ( job.EQ.0 ) ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLAGTS', -info )
         RETURN
      END IF
*
      IF( n.EQ.0 )
     $   RETURN
*
      eps = dlamch( 'Epsilon' )
      sfmin = dlamch( 'Safe minimum' )
      bignum = one / sfmin
*
      IF( job.LT.0 ) THEN
         IF( tol.LE.zero ) THEN
            tol = abs( a( 1 ) )
            IF( n.GT.1 )
     $         tol = max( tol, abs( a( 2 ) ), abs( b( 1 ) ) )
            DO 10 k = 3, n
               tol = max( tol, abs( a( k ) ), abs( b( k-1 ) ),
     $               abs( d( k-2 ) ) )
   10       CONTINUE
            tol = tol*eps
            IF( tol.EQ.zero )
     $         tol = eps
         END IF
      END IF
*
      IF( abs( job ).EQ.1 ) THEN
         DO 20 k = 2, n
            IF( in( k-1 ).EQ.0 ) THEN
               y( k ) = y( k ) - c( k-1 )*y( k-1 )
            ELSE
               temp = y( k-1 )
               y( k-1 ) = y( k )
               y( k ) = temp - c( k-1 )*y( k )
            END IF
   20    CONTINUE
         IF( job.EQ.1 ) THEN
            DO 30 k = n, 1, -1
               IF( k.LE.n-2 ) THEN
                  temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 )
               ELSE IF( k.EQ.n-1 ) THEN
                  temp = y( k ) - b( k )*y( k+1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     info = k
                     RETURN
                  END IF
               END IF
               y( k ) = temp / ak
   30       CONTINUE
         ELSE
            DO 50 k = n, 1, -1
               IF( k.LE.n-2 ) THEN
                  temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 )
               ELSE IF( k.EQ.n-1 ) THEN
                  temp = y( k ) - b( k )*y( k+1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               pert = sign( tol, ak )
   40          CONTINUE
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        ak = ak + pert
                        pert = 2*pert
                        GO TO 40
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     ak = ak + pert
                     pert = 2*pert
                     GO TO 40
                  END IF
               END IF
               y( k ) = temp / ak
   50       CONTINUE
         END IF
      ELSE
*
*        Come to here if  JOB = 2 or -2
*
         IF( job.EQ.2 ) THEN
            DO 60 k = 1, n
               IF( k.GE.3 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 )
               ELSE IF( k.EQ.2 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     info = k
                     RETURN
                  END IF
               END IF
               y( k ) = temp / ak
   60       CONTINUE
         ELSE
            DO 80 k = 1, n
               IF( k.GE.3 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 )
               ELSE IF( k.EQ.2 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               pert = sign( tol, ak )
   70          CONTINUE
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        ak = ak + pert
                        pert = 2*pert
                        GO TO 70
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     ak = ak + pert
                     pert = 2*pert
                     GO TO 70
                  END IF
               END IF
               y( k ) = temp / ak
   80       CONTINUE
         END IF
*
         DO 90 k = n, 2, -1
            IF( in( k-1 ).EQ.0 ) THEN
               y( k-1 ) = y( k-1 ) - c( k-1 )*y( k )
            ELSE
               temp = y( k-1 )
               y( k-1 ) = y( k )
               y( k ) = temp - c( k-1 )*y( k )
            END IF
   90    CONTINUE
      END IF
*
*     End of DLAGTS
*

dlaisnan()

logical function dlaisnan	(	double precision, intent(in)	din1,
		double precision, intent(in)	din2 )

DLAISNAN tests input for NaN by comparing two arguments for inequality.

Download DLAISNAN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This routine is not for general use.  It exists solely to avoid
!> over-optimization in DISNAN.
!>
!> DLAISNAN checks for NaNs by comparing its two arguments for
!> inequality.  NaN is the only floating-point value where NaN != NaN
!> returns .TRUE.  To check for NaNs, pass the same variable as both
!> arguments.
!>
!> A compiler must assume that the two arguments are
!> not the same variable, and the test will not be optimized away.
!> Interprocedural or whole-program optimization may delete this
!> test.  The ISNAN functions will be replaced by the correct
!> Fortran 03 intrinsic once the intrinsic is widely available.
!> 

Parameters

[in]	DIN1	!> DIN1 is DOUBLE PRECISION !>
[in]	DIN2	!> DIN2 is DOUBLE PRECISION !> Two numbers to compare for inequality. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 73 of file dlaisnan.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
*     ..
*
*  =====================================================================
*
*  .. Executable Statements ..
      dlaisnan = (din1.NE.din2)
      RETURN

dlaneg()

integer function dlaneg	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	lld,
		double precision	sigma,
		double precision	pivmin,
		integer	r )

DLANEG computes the Sturm count.

Download DLANEG + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> 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,  SIAM Journal on
!>   Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624
!>   (Tech report version in LAWN 172 with the same title.)
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	LLD	!> LLD is DOUBLE PRECISION array, dimension (N-1) !> The (N-1) elements L(i)*L(i)*D(i). !>
[in]	SIGMA	!> SIGMA is DOUBLE PRECISION !> Shift amount in T - sigma I = L D L^T. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot in the Sturm sequence. May be used !> when zero pivots are encountered on non-IEEE-754 !> architectures. !>
[in]	R	!> R is INTEGER !> The twist index for the twisted factorization that is used !> for the negcount. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA
Jason Riedy, University of California, Berkeley, USA

Definition at line 117 of file dlaneg.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N, R
      DOUBLE PRECISION   PIVMIN, SIGMA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), LLD( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d0, one = 1.0d0 )
*     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.
      INTEGER BLKLEN
      parameter( blklen = 128 )
*     ..
*     .. Local Scalars ..
      INTEGER            BJ, J, NEG1, NEG2, NEGCNT
      DOUBLE PRECISION   BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
      LOGICAL SAWNAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC min, max
*     ..
*     .. External Functions ..
      LOGICAL DISNAN
      EXTERNAL disnan
*     ..
*     .. Executable Statements ..
 
      negcnt = 0
 
*     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
      t = -sigma
      DO 210 bj = 1, r-1, blklen
         neg1 = 0
         bsav = t
         DO 21 j = bj, min(bj+blklen-1, r-1)
            dplus = d( j ) + t
            IF( dplus.LT.zero ) neg1 = neg1 + 1
            tmp = t / dplus
            t = tmp * lld( j ) - sigma
 21      CONTINUE
         sawnan = 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
            t = bsav
            DO 22 j = bj, min(bj+blklen-1, r-1)
               dplus = d( j ) + t
               IF( dplus.LT.zero ) neg1 = neg1 + 1
               tmp = t / dplus
               IF (disnan(tmp)) tmp = one
               t = tmp * lld(j) - sigma
 22         CONTINUE
         END IF
         negcnt = negcnt + neg1
 210  CONTINUE
*
*     II) lower part: L D L^T - SIGMA I = U- D- U-^T
      p = d( n ) - sigma
      DO 230 bj = n-1, r, -blklen
         neg2 = 0
         bsav = p
         DO 23 j = bj, max(bj-blklen+1, r), -1
            dminus = lld( j ) + p
            IF( dminus.LT.zero ) neg2 = neg2 + 1
            tmp = p / dminus
            p = tmp * d( j ) - sigma
 23      CONTINUE
         sawnan = disnan( p )
*     As above, run a slower version that substitutes 1 for Inf/Inf.
*
         IF( sawnan ) THEN
            neg2 = 0
            p = bsav
            DO 24 j = bj, max(bj-blklen+1, r), -1
               dminus = lld( j ) + p
               IF( dminus.LT.zero ) neg2 = neg2 + 1
               tmp = p / dminus
               IF (disnan(tmp)) tmp = one
               p = tmp * d(j) - sigma
 24         CONTINUE
         END IF
         negcnt = negcnt + neg2
 230  CONTINUE
*
*     III) Twist index
*       T was shifted by SIGMA initially.
      gamma = (t + sigma) + p
      IF( gamma.LT.zero ) negcnt = negcnt+1
 
      dlaneg = negcnt

dlanst()

double precision function dlanst	(	character	norm,
		integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e )

DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.

Download DLANST + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLANST  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> real symmetric tridiagonal matrix A.
!> 

Returns

DLANST

!>
!>    DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!> 

Parameters

[in]	NORM	!> NORM is CHARACTER*1 !> Specifies the value to be returned in DLANST as described !> above. !>
[in]	N	!> N is INTEGER !> The order of the matrix A. N >= 0. When N = 0, DLANST is !> set to zero. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The diagonal elements of A. !>
[in]	E	!> E is DOUBLE PRECISION array, dimension (N-1) !> The (n-1) sub-diagonal or super-diagonal elements of A. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 99 of file dlanst.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   ANORM, SCALE, SUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, DISNAN
      EXTERNAL           lsame, disnan
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlassq
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
      IF( n.LE.0 ) THEN
         anorm = zero
      ELSE IF( lsame( norm, 'M' ) ) THEN
*
*        Find max(abs(A(i,j))).
*
         anorm = abs( d( n ) )
         DO 10 i = 1, n - 1
            sum = abs( d( i ) )
            IF( anorm .LT. sum .OR. disnan( sum ) ) anorm = sum
            sum = abs( e( i ) )
            IF( anorm .LT. sum .OR. disnan( sum ) ) anorm = sum
   10    CONTINUE
      ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' .OR.
     $         lsame( norm, 'I' ) ) THEN
*
*        Find norm1(A).
*
         IF( n.EQ.1 ) THEN
            anorm = abs( d( 1 ) )
         ELSE
            anorm = abs( d( 1 ) )+abs( e( 1 ) )
            sum = abs( e( n-1 ) )+abs( d( n ) )
            IF( anorm .LT. sum .OR. disnan( sum ) ) anorm = sum
            DO 20 i = 2, n - 1
               sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
               IF( anorm .LT. sum .OR. disnan( sum ) ) anorm = sum
   20       CONTINUE
         END IF
      ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
*
*        Find normF(A).
*
         scale = zero
         sum = one
         IF( n.GT.1 ) THEN
            CALL dlassq( n-1, e, 1, scale, sum )
            sum = 2*sum
         END IF
         CALL dlassq( n, d, 1, scale, sum )
         anorm = scale*sqrt( sum )
      END IF
*
      dlanst = anorm
      RETURN
*
*     End of DLANST
*

dlapy2()

double precision function dlapy2	(	double precision	x,
		double precision	y )

DLAPY2 returns sqrt(x2+y2).

Download DLAPY2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
!> overflow and unnecessary underflow.
!> 

Parameters

[in]	X	!> X is DOUBLE PRECISION !>
[in]	Y	!> Y is DOUBLE PRECISION !> X and Y specify the values x and y. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 62 of file dlapy2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, Z, HUGEVAL
      LOGICAL            X_IS_NAN, Y_IS_NAN
*     ..
*     .. External Functions ..
      LOGICAL            DISNAN
      EXTERNAL           disnan
*     ..
*     .. External Subroutines ..
      DOUBLE PRECISION   DLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. Executable Statements ..
*
      x_is_nan = disnan( x )
      y_is_nan = disnan( y )
      IF ( x_is_nan ) dlapy2 = x
      IF ( y_is_nan ) dlapy2 = y
      hugeval = dlamch( 'Overflow' )
*
      IF ( .NOT.( x_is_nan.OR.y_is_nan ) ) THEN
         xabs = abs( x )
         yabs = abs( y )
         w = max( xabs, yabs )
         z = min( xabs, yabs )
         IF( z.EQ.zero .OR. w.GT.hugeval ) THEN
            dlapy2 = w
         ELSE
            dlapy2 = w*sqrt( one+( z / w )**2 )
         END IF
      END IF
      RETURN
*
*     End of DLAPY2
*

dlapy3()

double precision function dlapy3	(	double precision	x,
		double precision	y,
		double precision	z )

DLAPY3 returns sqrt(x2+y2+z2).

Download DLAPY3 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
!> unnecessary overflow and unnecessary underflow.
!> 

Parameters

[in]	X	!> X is DOUBLE PRECISION !>
[in]	Y	!> Y is DOUBLE PRECISION !>
[in]	Z	!> Z is DOUBLE PRECISION !> X, Y and Z specify the values x, y and z. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 67 of file dlapy3.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y, Z
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, ZABS, HUGEVAL
*     ..
*     .. External Subroutines ..
      DOUBLE PRECISION   DLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sqrt
*     ..
*     .. Executable Statements ..
*
      hugeval = dlamch( 'Overflow' )
      xabs = abs( x )
      yabs = abs( y )
      zabs = abs( z )
      w = max( xabs, yabs, zabs )
      IF( w.EQ.zero .OR. w.GT.hugeval ) THEN
*     W can be zero for max(0,nan,0)
*     adding all three entries together will make sure
*     NaN will not disappear.
         dlapy3 =  xabs + yabs + zabs
      ELSE
         dlapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+
     $            ( zabs / w )**2 )
      END IF
      RETURN
*
*     End of DLAPY3
*

dlarnv()

subroutine dlarnv	(	integer	idist,
		integer, dimension( 4 )	iseed,
		integer	n,
		double precision, dimension( * )	x )

DLARNV returns a vector of random numbers from a uniform or normal distribution.

Download DLARNV + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARNV returns a vector of n random real numbers from a uniform or
!> normal distribution.
!> 

Parameters

[in]	IDIST	!> IDIST is INTEGER !> Specifies the distribution of the random numbers: !> = 1: uniform (0,1) !> = 2: uniform (-1,1) !> = 3: normal (0,1) !>
[in,out]	ISEED	!> ISEED is INTEGER array, dimension (4) !> On entry, the seed of the random number generator; the array !> elements must be between 0 and 4095, and ISEED(4) must be !> odd. !> On exit, the seed is updated. !>
[in]	N	!> N is INTEGER !> The number of random numbers to be generated. !>
[out]	X	!> X is DOUBLE PRECISION array, dimension (N) !> The generated random numbers. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  This routine calls the auxiliary routine DLARUV to generate random
!>  real numbers from a uniform (0,1) distribution, in batches of up to
!>  128 using vectorisable code. The Box-Muller method is used to
!>  transform numbers from a uniform to a normal distribution.
!> 

Definition at line 96 of file dlarnv.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IDIST, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   X( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO
      parameter( one = 1.0d+0, two = 2.0d+0 )
      INTEGER            LV
      parameter( lv = 128 )
      DOUBLE PRECISION   TWOPI
      parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IL, IL2, IV
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   U( LV )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          cos, log, min, sqrt
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlaruv
*     ..
*     .. Executable Statements ..
*
      DO 40 iv = 1, n, lv / 2
         il = min( lv / 2, n-iv+1 )
         IF( idist.EQ.3 ) THEN
            il2 = 2*il
         ELSE
            il2 = il
         END IF
*
*        Call DLARUV to generate IL2 numbers from a uniform (0,1)
*        distribution (IL2 <= LV)
*
         CALL dlaruv( iseed, il2, u )
*
         IF( idist.EQ.1 ) THEN
*
*           Copy generated numbers
*
            DO 10 i = 1, il
               x( iv+i-1 ) = u( i )
   10       CONTINUE
         ELSE IF( idist.EQ.2 ) THEN
*
*           Convert generated numbers to uniform (-1,1) distribution
*
            DO 20 i = 1, il
               x( iv+i-1 ) = two*u( i ) - one
   20       CONTINUE
         ELSE IF( idist.EQ.3 ) THEN
*
*           Convert generated numbers to normal (0,1) distribution
*
            DO 30 i = 1, il
               x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*
     $                       cos( twopi*u( 2*i ) )
   30       CONTINUE
         END IF
   40 CONTINUE
      RETURN
*
*     End of DLARNV
*

dlarra()

subroutine dlarra	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( * )	e2,
		double precision	spltol,
		double precision	tnrm,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	info )

DLARRA computes the splitting points with the specified threshold.

Download DLARRA + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Compute the splitting points with threshold SPLTOL.
!> DLARRA sets any  off-diagonal elements to zero.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> On entry, the N diagonal elements of the tridiagonal !> matrix T. !>
[in,out]	E	!> E is DOUBLE PRECISION array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) need not be set. !> On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, !> are set to zero, the other entries of E are untouched. !>
[in,out]	E2	!> E2 is DOUBLE PRECISION array, dimension (N) !> On entry, the first (N-1) entries contain the SQUARES of the !> subdiagonal elements of the tridiagonal matrix T; !> E2(N) need not be set. !> On exit, the entries E2( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, have been set to zero !>
[in]	SPLTOL	!> SPLTOL is DOUBLE PRECISION !> The threshold for splitting. Two criteria can be used: !> SPLTOL<0 : criterion based on absolute off-diagonal value !> SPLTOL>0 : criterion that preserves relative accuracy !>
[in]	TNRM	!> TNRM is DOUBLE PRECISION !> The norm of the matrix. !>
[out]	NSPLIT	!> NSPLIT is INTEGER !> The number of blocks T splits into. 1 <= NSPLIT <= N. !>
[out]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into blocks. !> The first block consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 134 of file dlarra.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N, NSPLIT
      DOUBLE PRECISION    SPLTOL, TNRM
*     ..
*     .. Array Arguments ..
      INTEGER            ISPLIT( * )
      DOUBLE PRECISION   D( * ), E( * ), E2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      DOUBLE PRECISION   EABS, TMP1
 
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Compute splitting points
      nsplit = 1
      IF(spltol.LT.zero) THEN
*        Criterion based on absolute off-diagonal value
         tmp1 = abs(spltol)* tnrm
         DO 9 i = 1, n-1
            eabs = abs( e(i) )
            IF( eabs .LE. tmp1) THEN
               e(i) = zero
               e2(i) = zero
               isplit( nsplit ) = i
               nsplit = nsplit + 1
            END IF
 9       CONTINUE
      ELSE
*        Criterion that guarantees relative accuracy
         DO 10 i = 1, n-1
            eabs = abs( e(i) )
            IF( eabs .LE. spltol * sqrt(abs(d(i)))*sqrt(abs(d(i+1))) )
     $      THEN
               e(i) = zero
               e2(i) = zero
               isplit( nsplit ) = i
               nsplit = nsplit + 1
            END IF
 10      CONTINUE
      ENDIF
      isplit( nsplit ) = n
 
      RETURN
*
*     End of DLARRA
*

dlarrb()

subroutine dlarrb	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	lld,
		integer	ifirst,
		integer	ilast,
		double precision	rtol1,
		double precision	rtol2,
		integer	offset,
		double precision, dimension( * )	w,
		double precision, dimension( * )	wgap,
		double precision, dimension( * )	werr,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		double precision	pivmin,
		double precision	spdiam,
		integer	twist,
		integer	info )

DLARRB provides limited bisection to locate eigenvalues for more accuracy.

Download DLARRB + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the relatively robust representation(RRR) L D L^T, DLARRB
!> does  bisection to refine the eigenvalues of L D L^T,
!> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
!> guesses for these eigenvalues are input in W, the corresponding estimate
!> of the error in these guesses and their gaps are input in WERR
!> and WGAP, respectively. During bisection, intervals
!> [left, right] are maintained by storing their mid-points and
!> semi-widths in the arrays W and WERR respectively.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	LLD	!> LLD is DOUBLE PRECISION array, dimension (N-1) !> The (N-1) elements L(i)*L(i)*D(i). !>
[in]	IFIRST	!> IFIRST is INTEGER !> The index of the first eigenvalue to be computed. !>
[in]	ILAST	!> ILAST is INTEGER !> The index of the last eigenvalue to be computed. !>
[in]	RTOL1	!> RTOL1 is DOUBLE PRECISION !>
[in]	RTOL2	!> RTOL2 is DOUBLE PRECISION !> Tolerance for the convergence of the bisection intervals. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) !> where GAP is the (estimated) distance to the nearest !> eigenvalue. !>
[in]	OFFSET	!> OFFSET is INTEGER !> Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET !> through ILAST-OFFSET elements of these arrays are to be used. !>
[in,out]	W	!> W is DOUBLE PRECISION array, dimension (N) !> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are !> estimates of the eigenvalues of L D L^T indexed IFIRST through !> ILAST. !> On output, these estimates are refined. !>
[in,out]	WGAP	!> WGAP is DOUBLE PRECISION array, dimension (N-1) !> On input, the (estimated) gaps between consecutive !> eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between !> eigenvalues I and I+1. Note that if IFIRST = ILAST !> then WGAP(IFIRST-OFFSET) must be set to ZERO. !> On output, these gaps are refined. !>
[in,out]	WERR	!> WERR is DOUBLE PRECISION array, dimension (N) !> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are !> the errors in the estimates of the corresponding elements in W. !> On output, these errors are refined. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (2*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (2*N) !> Workspace. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot in the Sturm sequence. !>
[in]	SPDIAM	!> SPDIAM is DOUBLE PRECISION !> The spectral diameter of the matrix. !>
[in]	TWIST	!> TWIST is INTEGER !> The twist index for the twisted factorization that is used !> for the negcount. !> TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T !> TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T !> TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) !>
[out]	INFO	!> INFO is INTEGER !> Error flag. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 193 of file dlarrb.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N, OFFSET, TWIST
      DOUBLE PRECISION   PIVMIN, RTOL1, RTOL2, SPDIAM
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), LLD( * ), W( * ),
     $                   WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO, HALF
      parameter( zero = 0.0d0, two = 2.0d0,
     $                   half = 0.5d0 )
      INTEGER   MAXITR
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
     $                   OLNINT, PREV, R
      DOUBLE PRECISION   BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
     $                   RGAP, RIGHT, TMP, WIDTH
*     ..
*     .. External Functions ..
      INTEGER            DLANEG
      EXTERNAL           dlaneg
*
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
      mnwdth = two * pivmin
*
      r = twist
      IF((r.LT.1).OR.(r.GT.n)) r = n
*
*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
*     for an unconverged interval is set to the index of the next unconverged
*     interval, and is -1 or 0 for a converged interval. Thus a linked
*     list of unconverged intervals is set up.
*
      i1 = ifirst
*     The number of unconverged intervals
      nint = 0
*     The last unconverged interval found
      prev = 0
 
      rgap = wgap( i1-offset )
      DO 75 i = i1, ilast
         k = 2*i
         ii = i - offset
         left = w( ii ) - werr( ii )
         right = w( ii ) + werr( ii )
         lgap = rgap
         rgap = wgap( ii )
         gap = min( lgap, rgap )
 
*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
*        Do while( NEGCNT(LEFT).GT.I-1 )
*
         back = werr( ii )
 20      CONTINUE
         negcnt = dlaneg( n, d, lld, left, pivmin, r )
         IF( negcnt.GT.i-1 ) THEN
            left = left - back
            back = two*back
            GO TO 20
         END IF
*
*        Do while( NEGCNT(RIGHT).LT.I )
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
         back = werr( ii )
 50      CONTINUE
 
         negcnt = dlaneg( n, d, lld, right, pivmin, r )
          IF( negcnt.LT.i ) THEN
             right = right + back
             back = two*back
             GO TO 50
          END IF
         width = half*abs( left - right )
         tmp = max( abs( left ), abs( right ) )
         cvrgd = max(rtol1*gap,rtol2*tmp)
         IF( width.LE.cvrgd .OR. width.LE.mnwdth ) THEN
*           This interval has already converged and does not need refinement.
*           (Note that the gaps might change through refining the
*            eigenvalues, however, they can only get bigger.)
*           Remove it from the list.
            iwork( k-1 ) = -1
*           Make sure that I1 always points to the first unconverged interval
            IF((i.EQ.i1).AND.(i.LT.ilast)) i1 = i + 1
            IF((prev.GE.i1).AND.(i.LE.ilast)) iwork( 2*prev-1 ) = i + 1
         ELSE
*           unconverged interval found
            prev = i
            nint = nint + 1
            iwork( k-1 ) = i + 1
            iwork( k ) = negcnt
         END IF
         work( k-1 ) = left
         work( k ) = right
 75   CONTINUE
 
*
*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
*     and while (ITER.LT.MAXITR)
*
      iter = 0
 80   CONTINUE
      prev = i1 - 1
      i = i1
      olnint = nint
 
      DO 100 ip = 1, olnint
         k = 2*i
         ii = i - offset
         rgap = wgap( ii )
         lgap = rgap
         IF(ii.GT.1) lgap = wgap( ii-1 )
         gap = min( lgap, rgap )
         next = iwork( k-1 )
         left = work( k-1 )
         right = work( k )
         mid = half*( left + right )
 
*        semiwidth of interval
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
         cvrgd = max(rtol1*gap,rtol2*tmp)
         IF( ( width.LE.cvrgd ) .OR. ( width.LE.mnwdth ).OR.
     $       ( iter.EQ.maxitr ) )THEN
*           reduce number of unconverged intervals
            nint = nint - 1
*           Mark interval as converged.
            iwork( k-1 ) = 0
            IF( i1.EQ.i ) THEN
               i1 = next
            ELSE
*              Prev holds the last unconverged interval previously examined
               IF(prev.GE.i1) iwork( 2*prev-1 ) = next
            END IF
            i = next
            GO TO 100
         END IF
         prev = i
*
*        Perform one bisection step
*
         negcnt = dlaneg( n, d, lld, mid, pivmin, r )
         IF( negcnt.LE.i-1 ) THEN
            work( k-1 ) = mid
         ELSE
            work( k ) = mid
         END IF
         i = next
 100  CONTINUE
      iter = iter + 1
*     do another loop if there are still unconverged intervals
*     However, in the last iteration, all intervals are accepted
*     since this is the best we can do.
      IF( ( nint.GT.0 ).AND.(iter.LE.maxitr) ) GO TO 80
*
*
*     At this point, all the intervals have converged
      DO 110 i = ifirst, ilast
         k = 2*i
         ii = i - offset
*        All intervals marked by '0' have been refined.
         IF( iwork( k-1 ).EQ.0 ) THEN
            w( ii ) = half*( work( k-1 )+work( k ) )
            werr( ii ) = work( k ) - w( ii )
         END IF
 110  CONTINUE
*
      DO 111 i = ifirst+1, ilast
         k = 2*i
         ii = i - offset
         wgap( ii-1 ) = max( zero,
     $                     w(ii) - werr(ii) - w( ii-1 ) - werr( ii-1 ))
 111  CONTINUE
 
      RETURN
*
*     End of DLARRB
*

dlarrc()

subroutine dlarrc	(	character	jobt,
		integer	n,
		double precision	vl,
		double precision	vu,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision	pivmin,
		integer	eigcnt,
		integer	lcnt,
		integer	rcnt,
		integer	info )

DLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.

Download DLARRC + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Find the number of eigenvalues of the symmetric tridiagonal matrix T
!> that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
!> if JOBT = 'L'.
!> 

Parameters

[in]	JOBT	!> JOBT is CHARACTER*1 !> = 'T': Compute Sturm count for matrix T. !> = 'L': Compute Sturm count for matrix L D L^T. !>
[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	VL	!> VL is DOUBLE PRECISION !> The lower bound for the eigenvalues. !>
[in]	VU	!> VU is DOUBLE PRECISION !> The upper bound for the eigenvalues. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. !> JOBT = 'L': The N diagonal elements of the diagonal matrix D. !>
[in]	E	!> E is DOUBLE PRECISION array, dimension (N) !> JOBT = 'T': The N-1 offdiagonal elements of the matrix T. !> JOBT = 'L': The N-1 offdiagonal elements of the matrix L. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot in the Sturm sequence for T. !>
[out]	EIGCNT	!> EIGCNT is INTEGER !> The number of eigenvalues of the symmetric tridiagonal matrix T !> that are in the interval (VL,VU] !>
[out]	LCNT	!> LCNT is INTEGER !>
[out]	RCNT	!> RCNT is INTEGER !> The left and right negcounts of the interval. !>
[out]	INFO	!> INFO is INTEGER !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 135 of file dlarrc.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOBT
      INTEGER            EIGCNT, INFO, LCNT, N, RCNT
      DOUBLE PRECISION   PIVMIN, VL, VU
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      LOGICAL            MATT
      DOUBLE PRECISION   LPIVOT, RPIVOT, SL, SU, TMP, TMP2
 
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      lcnt = 0
      rcnt = 0
      eigcnt = 0
      matt = lsame( jobt, 'T' )
 
 
      IF (matt) THEN
*        Sturm sequence count on T
         lpivot = d( 1 ) - vl
         rpivot = d( 1 ) - vu
         IF( lpivot.LE.zero ) THEN
            lcnt = lcnt + 1
         ENDIF
         IF( rpivot.LE.zero ) THEN
            rcnt = rcnt + 1
         ENDIF
         DO 10 i = 1, n-1
            tmp = e(i)**2
            lpivot = ( d( i+1 )-vl ) - tmp/lpivot
            rpivot = ( d( i+1 )-vu ) - tmp/rpivot
            IF( lpivot.LE.zero ) THEN
               lcnt = lcnt + 1
            ENDIF
            IF( rpivot.LE.zero ) THEN
               rcnt = rcnt + 1
            ENDIF
 10      CONTINUE
      ELSE
*        Sturm sequence count on L D L^T
         sl = -vl
         su = -vu
         DO 20 i = 1, n - 1
            lpivot = d( i ) + sl
            rpivot = d( i ) + su
            IF( lpivot.LE.zero ) THEN
               lcnt = lcnt + 1
            ENDIF
            IF( rpivot.LE.zero ) THEN
               rcnt = rcnt + 1
            ENDIF
            tmp = e(i) * d(i) * e(i)
*
            tmp2 = tmp / lpivot
            IF( tmp2.EQ.zero ) THEN
               sl =  tmp - vl
            ELSE
               sl = sl*tmp2 - vl
            END IF
*
            tmp2 = tmp / rpivot
            IF( tmp2.EQ.zero ) THEN
               su =  tmp - vu
            ELSE
               su = su*tmp2 - vu
            END IF
 20      CONTINUE
         lpivot = d( n ) + sl
         rpivot = d( n ) + su
         IF( lpivot.LE.zero ) THEN
            lcnt = lcnt + 1
         ENDIF
         IF( rpivot.LE.zero ) THEN
            rcnt = rcnt + 1
         ENDIF
      ENDIF
      eigcnt = rcnt - lcnt
 
      RETURN
*
*     End of DLARRC
*

dlarrd()

subroutine dlarrd	(	character	range,
		character	order,
		integer	n,
		double precision	vl,
		double precision	vu,
		integer	il,
		integer	iu,
		double precision, dimension( * )	gers,
		double precision	reltol,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( * )	e2,
		double precision	pivmin,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	m,
		double precision, dimension( * )	w,
		double precision, dimension( * )	werr,
		double precision	wl,
		double precision	wu,
		integer, dimension( * )	iblock,
		integer, dimension( * )	indexw,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

DLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy.

Download DLARRD + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARRD computes the eigenvalues of a symmetric tridiagonal
!> matrix T to suitable accuracy. This is an auxiliary code to be
!> called from DSTEMR.
!> The user may ask for all eigenvalues, all eigenvalues
!> in the half-open interval (VL, VU], or the IL-th through IU-th
!> eigenvalues.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966.
!> 

Parameters

[in]	RANGE	!> RANGE is CHARACTER*1 !> = 'A': () all eigenvalues will be found. !> = 'V': () all eigenvalues in the half-open interval !> (VL, VU] will be found. !> = 'I': () the IL-th through IU-th eigenvalues (of the !> entire matrix) will be found. !>
[in]	ORDER	!> ORDER is CHARACTER*1 !> = 'B': () the eigenvalues will be grouped by !> split-off block (see IBLOCK, ISPLIT) and !> ordered from smallest to largest within !> the block. !> = 'E': () !> the eigenvalues for the entire matrix !> will be ordered from smallest to !> largest. !>
[in]	N	!> N is INTEGER !> The order of the tridiagonal matrix T. N >= 0. !>
[in]	VL	!> VL is DOUBLE PRECISION !> If RANGE='V', the lower bound of the interval to !> be searched for eigenvalues. Eigenvalues less than or equal !> to VL, or greater than VU, will not be returned. VL < VU. !> Not referenced if RANGE = 'A' or 'I'. !>
[in]	VU	!> VU is DOUBLE PRECISION !> If RANGE='V', the upper bound of the interval to !> be searched for eigenvalues. Eigenvalues less than or equal !> to VL, or greater than VU, will not be returned. VL < VU. !> Not referenced if RANGE = 'A' or 'I'. !>
[in]	IL	!> IL is INTEGER !> If RANGE='I', the index of the !> smallest eigenvalue to be returned. !> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. !> Not referenced if RANGE = 'A' or 'V'. !>
[in]	IU	!> IU is INTEGER !> If RANGE='I', the index of the !> largest eigenvalue to be returned. !> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. !> Not referenced if RANGE = 'A' or 'V'. !>
[in]	GERS	!> GERS is DOUBLE PRECISION array, dimension (2*N) !> The N Gerschgorin intervals (the i-th Gerschgorin interval !> is (GERS(2*i-1), GERS(2*i)). !>
[in]	RELTOL	!> RELTOL is DOUBLE PRECISION !> The minimum relative width of an interval. When an interval !> is narrower than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The n diagonal elements of the tridiagonal matrix T. !>
[in]	E	!> E is DOUBLE PRECISION array, dimension (N-1) !> The (n-1) off-diagonal elements of the tridiagonal matrix T. !>
[in]	E2	!> E2 is DOUBLE PRECISION array, dimension (N-1) !> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot allowed in the Sturm sequence for T. !>
[in]	NSPLIT	!> NSPLIT is INTEGER !> The number of diagonal blocks in the matrix T. !> 1 <= NSPLIT <= N. !>
[in]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into submatrices. !> The first submatrix consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !> (Only the first NSPLIT elements will actually be used, but !> since the user cannot know a priori what value NSPLIT will !> have, N words must be reserved for ISPLIT.) !>
[out]	M	!> M is INTEGER !> The actual number of eigenvalues found. 0 <= M <= N. !> (See also the description of INFO=2,3.) !>
[out]	W	!> W is DOUBLE PRECISION array, dimension (N) !> On exit, the first M elements of W will contain the !> eigenvalue approximations. DLARRD computes an interval !> I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue !> approximation is given as the interval midpoint !> W(j)= ( a_j + b_j)/2. The corresponding error is bounded by !> WERR(j) = abs( a_j - b_j)/2 !>
[out]	WERR	!> WERR is DOUBLE PRECISION array, dimension (N) !> The error bound on the corresponding eigenvalue approximation !> in W. !>
[out]	WL	!> WL is DOUBLE PRECISION !>
[out]	WU	!> WU is DOUBLE PRECISION !> The interval (WL, WU] contains all the wanted eigenvalues. !> If RANGE='V', then WL=VL and WU=VU. !> If RANGE='A', then WL and WU are the global Gerschgorin bounds !> on the spectrum. !> If RANGE='I', then WL and WU are computed by DLAEBZ from the !> index range specified. !>
[out]	IBLOCK	!> IBLOCK is INTEGER array, dimension (N) !> At each row/column j where E(j) is zero or small, the !> matrix T is considered to split into a block diagonal !> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which !> block (from 1 to the number of blocks) the eigenvalue W(i) !> belongs. (DLARRD may use the remaining N-M elements as !> workspace.) !>
[out]	INDEXW	!> INDEXW is INTEGER array, dimension (N) !> The indices of the eigenvalues within each block (submatrix); !> for example, INDEXW(i)= j and IBLOCK(i)=k imply that the !> i-th eigenvalue W(i) is the j-th eigenvalue in block k. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (4*N) !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (3*N) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: some or all of the eigenvalues failed to converge or !> were not computed: !> =1 or 3: Bisection failed to converge for some !> eigenvalues; these eigenvalues are flagged by a !> negative block number. The effect is that the !> eigenvalues may not be as accurate as the !> absolute and relative tolerances. This is !> generally caused by unexpectedly inaccurate !> arithmetic. !> =2 or 3: RANGE='I' only: Not all of the eigenvalues !> IL:IU were found. !> Effect: M < IU+1-IL !> Cause: non-monotonic arithmetic, causing the !> Sturm sequence to be non-monotonic. !> Cure: recalculate, using RANGE='A', and pick !> out eigenvalues IL:IU. In some cases, !> increasing the PARAMETER may !> make things work. !> = 4: RANGE='I', and the Gershgorin interval !> initially used was too small. No eigenvalues !> were computed. !> Probable cause: your machine has sloppy !> floating-point arithmetic. !> Cure: Increase the PARAMETER , !> recompile, and try again. !>

Internal Parameters:

!>  FUDGE   DOUBLE PRECISION, default = 2
!>          A  to widen the Gershgorin intervals.  Ideally,
!>          a value of 1 should work, but on machines with sloppy
!>          arithmetic, this needs to be larger.  The default for
!>          publicly released versions should be large enough to handle
!>          the worst machine around.  Note that this has no effect
!>          on accuracy of the solution.
!> 

Contributors:

W. Kahan, University of California, Berkeley, USA
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 325 of file dlarrd.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          ORDER, RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      DOUBLE PRECISION    PIVMIN, RELTOL, VL, VU, WL, WU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), INDEXW( * ),
     $                   ISPLIT( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), E2( * ),
     $                   GERS( * ), W( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF, FUDGE
      parameter( zero = 0.0d0, one = 1.0d0,
     $                     two = 2.0d0, half = one/two,
     $                     fudge = two )
      INTEGER   ALLRNG, VALRNG, INDRNG
      parameter( allrng = 1, valrng = 2, indrng = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NCNVRG, TOOFEW
      INTEGER            I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
     $                   IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
     $                   ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
     $                   NWL, NWU
      DOUBLE PRECISION   ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2,
     $                   TNORM, UFLOW, WKILL, WLU, WUL
 
*     ..
*     .. Local Arrays ..
      INTEGER            IDUMMA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           lsame, ilaenv, dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlaebz
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max, min
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Decode RANGE
*
      IF( lsame( range, 'A' ) ) THEN
         irange = allrng
      ELSE IF( lsame( range, 'V' ) ) THEN
         irange = valrng
      ELSE IF( lsame( range, 'I' ) ) THEN
         irange = indrng
      ELSE
         irange = 0
      END IF
*
*     Check for Errors
*
      IF( irange.LE.0 ) THEN
         info = -1
      ELSE IF( .NOT.(lsame(order,'B').OR.lsame(order,'E')) ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( irange.EQ.valrng ) THEN
         IF( vl.GE.vu )
     $      info = -5
      ELSE IF( irange.EQ.indrng .AND.
     $        ( il.LT.1 .OR. il.GT.max( 1, n ) ) ) THEN
         info = -6
      ELSE IF( irange.EQ.indrng .AND.
     $        ( iu.LT.min( n, il ) .OR. iu.GT.n ) ) THEN
         info = -7
      END IF
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
 
*     Initialize error flags
      info = 0
      ncnvrg = .false.
      toofew = .false.
 
*     Quick return if possible
      m = 0
      IF( n.EQ.0 ) RETURN
 
*     Simplification:
      IF( irange.EQ.indrng .AND. il.EQ.1 .AND. iu.EQ.n ) irange = 1
 
*     Get machine constants
      eps = dlamch( 'P' )
      uflow = dlamch( 'U' )
 
 
*     Special Case when N=1
*     Treat case of 1x1 matrix for quick return
      IF( n.EQ.1 ) THEN
         IF( (irange.EQ.allrng).OR.
     $       ((irange.EQ.valrng).AND.(d(1).GT.vl).AND.(d(1).LE.vu)).OR.
     $       ((irange.EQ.indrng).AND.(il.EQ.1).AND.(iu.EQ.1)) ) THEN
            m = 1
            w(1) = d(1)
*           The computation error of the eigenvalue is zero
            werr(1) = zero
            iblock( 1 ) = 1
            indexw( 1 ) = 1
         ENDIF
         RETURN
      END IF
 
*     NB is the minimum vector length for vector bisection, or 0
*     if only scalar is to be done.
      nb = ilaenv( 1, 'DSTEBZ', ' ', n, -1, -1, -1 )
      IF( nb.LE.1 ) nb = 0
 
*     Find global spectral radius
      gl = d(1)
      gu = d(1)
      DO 5 i = 1,n
         gl =  min( gl, gers( 2*i - 1))
         gu = max( gu, gers(2*i) )
 5    CONTINUE
*     Compute global Gerschgorin bounds and spectral diameter
      tnorm = max( abs( gl ), abs( gu ) )
      gl = gl - fudge*tnorm*eps*n - fudge*two*pivmin
      gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin
*     [JAN/28/2009] remove the line below since SPDIAM variable not use
*     SPDIAM = GU - GL
*     Input arguments for DLAEBZ:
*     The relative tolerance.  An interval (a,b] lies within
*     "relative tolerance" if  b-a < RELTOL*max(|a|,|b|),
      rtoli = reltol
*     Set the absolute tolerance for interval convergence to zero to force
*     interval convergence based on relative size of the interval.
*     This is dangerous because intervals might not converge when RELTOL is
*     small. But at least a very small number should be selected so that for
*     strongly graded matrices, the code can get relatively accurate
*     eigenvalues.
      atoli = fudge*two*uflow + fudge*two*pivmin
 
      IF( irange.EQ.indrng ) THEN
 
*        RANGE='I': Compute an interval containing eigenvalues
*        IL through IU. The initial interval [GL,GU] from the global
*        Gerschgorin bounds GL and GU is refined by DLAEBZ.
         itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
         work( n+1 ) = gl
         work( n+2 ) = gl
         work( n+3 ) = gu
         work( n+4 ) = gu
         work( n+5 ) = gl
         work( n+6 ) = gu
         iwork( 1 ) = -1
         iwork( 2 ) = -1
         iwork( 3 ) = n + 1
         iwork( 4 ) = n + 1
         iwork( 5 ) = il - 1
         iwork( 6 ) = iu
*
         CALL dlaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin,
     $         d, e, e2, iwork( 5 ), work( n+1 ), work( n+5 ), iout,
     $                iwork, w, iblock, iinfo )
         IF( iinfo .NE. 0 ) THEN
            info = iinfo
            RETURN
         END IF
*        On exit, output intervals may not be ordered by ascending negcount
         IF( iwork( 6 ).EQ.iu ) THEN
            wl = work( n+1 )
            wlu = work( n+3 )
            nwl = iwork( 1 )
            wu = work( n+4 )
            wul = work( n+2 )
            nwu = iwork( 4 )
         ELSE
            wl = work( n+2 )
            wlu = work( n+4 )
            nwl = iwork( 2 )
            wu = work( n+3 )
            wul = work( n+1 )
            nwu = iwork( 3 )
         END IF
*        On exit, the interval [WL, WLU] contains a value with negcount NWL,
*        and [WUL, WU] contains a value with negcount NWU.
         IF( nwl.LT.0 .OR. nwl.GE.n .OR. nwu.LT.1 .OR. nwu.GT.n ) THEN
            info = 4
            RETURN
         END IF
 
      ELSEIF( irange.EQ.valrng ) THEN
         wl = vl
         wu = vu
 
      ELSEIF( irange.EQ.allrng ) THEN
         wl = gl
         wu = gu
      ENDIF
 
 
 
*     Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
*     NWL accumulates the number of eigenvalues .le. WL,
*     NWU accumulates the number of eigenvalues .le. WU
      m = 0
      iend = 0
      info = 0
      nwl = 0
      nwu = 0
*
      DO 70 jblk = 1, nsplit
         ioff = iend
         ibegin = ioff + 1
         iend = isplit( jblk )
         in = iend - ioff
*
         IF( in.EQ.1 ) THEN
*           1x1 block
            IF( wl.GE.d( ibegin )-pivmin )
     $         nwl = nwl + 1
            IF( wu.GE.d( ibegin )-pivmin )
     $         nwu = nwu + 1
            IF( irange.EQ.allrng .OR.
     $           ( wl.LT.d( ibegin )-pivmin
     $             .AND. wu.GE. d( ibegin )-pivmin ) ) THEN
               m = m + 1
               w( m ) = d( ibegin )
               werr(m) = zero
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               iblock( m ) = jblk
               indexw( m ) = 1
            END IF
 
*        Disabled 2x2 case because of a failure on the following matrix
*        RANGE = 'I', IL = IU = 4
*          Original Tridiagonal, d = [
*           -0.150102010615740E+00
*           -0.849897989384260E+00
*           -0.128208148052635E-15
*            0.128257718286320E-15
*          ];
*          e = [
*           -0.357171383266986E+00
*           -0.180411241501588E-15
*           -0.175152352710251E-15
*          ];
*
*         ELSE IF( IN.EQ.2 ) THEN
**           2x2 block
*            DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
*            TMP1 = HALF*(D(IBEGIN)+D(IEND))
*            L1 = TMP1 - DISC
*            IF( WL.GE. L1-PIVMIN )
*     $         NWL = NWL + 1
*            IF( WU.GE. L1-PIVMIN )
*     $         NWU = NWU + 1
*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
*     $          L1-PIVMIN ) ) THEN
*               M = M + 1
*               W( M ) = L1
**              The uncertainty of eigenvalues of a 2x2 matrix is very small
*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
*               IBLOCK( M ) = JBLK
*               INDEXW( M ) = 1
*            ENDIF
*            L2 = TMP1 + DISC
*            IF( WL.GE. L2-PIVMIN )
*     $         NWL = NWL + 1
*            IF( WU.GE. L2-PIVMIN )
*     $         NWU = NWU + 1
*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
*     $          L2-PIVMIN ) ) THEN
*               M = M + 1
*               W( M ) = L2
**              The uncertainty of eigenvalues of a 2x2 matrix is very small
*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
*               IBLOCK( M ) = JBLK
*               INDEXW( M ) = 2
*            ENDIF
         ELSE
*           General Case - block of size IN >= 2
*           Compute local Gerschgorin interval and use it as the initial
*           interval for DLAEBZ
            gu = d( ibegin )
            gl = d( ibegin )
            tmp1 = zero
 
            DO 40 j = ibegin, iend
               gl =  min( gl, gers( 2*j - 1))
               gu = max( gu, gers(2*j) )
   40       CONTINUE
*           [JAN/28/2009]
*           change SPDIAM by TNORM in lines 2 and 3 thereafter
*           line 1: remove computation of SPDIAM (not useful anymore)
*           SPDIAM = GU - GL
*           GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
*           GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
            gl = gl - fudge*tnorm*eps*in - fudge*pivmin
            gu = gu + fudge*tnorm*eps*in + fudge*pivmin
*
            IF( irange.GT.1 ) THEN
               IF( gu.LT.wl ) THEN
*                 the local block contains none of the wanted eigenvalues
                  nwl = nwl + in
                  nwu = nwu + in
                  GO TO 70
               END IF
*              refine search interval if possible, only range (WL,WU] matters
               gl = max( gl, wl )
               gu = min( gu, wu )
               IF( gl.GE.gu )
     $            GO TO 70
            END IF
 
*           Find negcount of initial interval boundaries GL and GU
            work( n+1 ) = gl
            work( n+in+1 ) = gu
            CALL dlaebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,
     $                   d( ibegin ), e( ibegin ), e2( ibegin ),
     $                   idumma, work( n+1 ), work( n+2*in+1 ), im,
     $                   iwork, w( m+1 ), iblock( m+1 ), iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = iinfo
               RETURN
            END IF
*
            nwl = nwl + iwork( 1 )
            nwu = nwu + iwork( in+1 )
            iwoff = m - iwork( 1 )
 
*           Compute Eigenvalues
            itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /
     $              log( two ) ) + 2
            CALL dlaebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,
     $                   d( ibegin ), e( ibegin ), e2( ibegin ),
     $                   idumma, work( n+1 ), work( n+2*in+1 ), iout,
     $                   iwork, w( m+1 ), iblock( m+1 ), iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = iinfo
               RETURN
            END IF
*
*           Copy eigenvalues into W and IBLOCK
*           Use -JBLK for block number for unconverged eigenvalues.
*           Loop over the number of output intervals from DLAEBZ
            DO 60 j = 1, iout
*              eigenvalue approximation is middle point of interval
               tmp1 = half*( work( j+n )+work( j+in+n ) )
*              semi length of error interval
               tmp2 = half*abs( work( j+n )-work( j+in+n ) )
               IF( j.GT.iout-iinfo ) THEN
*                 Flag non-convergence.
                  ncnvrg = .true.
                  ib = -jblk
               ELSE
                  ib = jblk
               END IF
               DO 50 je = iwork( j ) + 1 + iwoff,
     $                 iwork( j+in ) + iwoff
                  w( je ) = tmp1
                  werr( je ) = tmp2
                  indexw( je ) = je - iwoff
                  iblock( je ) = ib
   50          CONTINUE
   60       CONTINUE
*
            m = m + im
         END IF
   70 CONTINUE
 
*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
      IF( irange.EQ.indrng ) THEN
         idiscl = il - 1 - nwl
         idiscu = nwu - iu
*
         IF( idiscl.GT.0 ) THEN
            im = 0
            DO 80 je = 1, m
*              Remove some of the smallest eigenvalues from the left so that
*              at the end IDISCL =0. Move all eigenvalues up to the left.
               IF( w( je ).LE.wlu .AND. idiscl.GT.0 ) THEN
                  idiscl = idiscl - 1
               ELSE
                  im = im + 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 80         CONTINUE
            m = im
         END IF
         IF( idiscu.GT.0 ) THEN
*           Remove some of the largest eigenvalues from the right so that
*           at the end IDISCU =0. Move all eigenvalues up to the left.
            im=m+1
            DO 81 je = m, 1, -1
               IF( w( je ).GE.wul .AND. idiscu.GT.0 ) THEN
                  idiscu = idiscu - 1
               ELSE
                  im = im - 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 81         CONTINUE
            jee = 0
            DO 82 je = im, m
               jee = jee + 1
               w( jee ) = w( je )
               werr( jee ) = werr( je )
               indexw( jee ) = indexw( je )
               iblock( jee ) = iblock( je )
 82         CONTINUE
            m = m-im+1
         END IF
 
         IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
*           Code to deal with effects of bad arithmetic. (If N(w) is
*           monotone non-decreasing, this should never happen.)
*           Some low eigenvalues to be discarded are not in (WL,WLU],
*           or high eigenvalues to be discarded are not in (WUL,WU]
*           so just kill off the smallest IDISCL/largest IDISCU
*           eigenvalues, by marking the corresponding IBLOCK = 0
            IF( idiscl.GT.0 ) THEN
               wkill = wu
               DO 100 jdisc = 1, idiscl
                  iw = 0
                  DO 90 je = 1, m
                     IF( iblock( je ).NE.0 .AND.
     $                    ( w( je ).LT.wkill .OR. iw.EQ.0 ) ) THEN
                        iw = je
                        wkill = w( je )
                     END IF
 90               CONTINUE
                  iblock( iw ) = 0
 100           CONTINUE
            END IF
            IF( idiscu.GT.0 ) THEN
               wkill = wl
               DO 120 jdisc = 1, idiscu
                  iw = 0
                  DO 110 je = 1, m
                     IF( iblock( je ).NE.0 .AND.
     $                    ( w( je ).GE.wkill .OR. iw.EQ.0 ) ) THEN
                        iw = je
                        wkill = w( je )
                     END IF
 110              CONTINUE
                  iblock( iw ) = 0
 120           CONTINUE
            END IF
*           Now erase all eigenvalues with IBLOCK set to zero
            im = 0
            DO 130 je = 1, m
               IF( iblock( je ).NE.0 ) THEN
                  im = im + 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 130        CONTINUE
            m = im
         END IF
         IF( idiscl.LT.0 .OR. idiscu.LT.0 ) THEN
            toofew = .true.
         END IF
      END IF
*
      IF(( irange.EQ.allrng .AND. m.NE.n ).OR.
     $   ( irange.EQ.indrng .AND. m.NE.iu-il+1 ) ) THEN
         toofew = .true.
      END IF
 
*     If ORDER='B', do nothing the eigenvalues are already sorted by
*        block.
*     If ORDER='E', sort the eigenvalues from smallest to largest
 
      IF( lsame(order,'E') .AND. nsplit.GT.1 ) THEN
         DO 150 je = 1, m - 1
            ie = 0
            tmp1 = w( je )
            DO 140 j = je + 1, m
               IF( w( j ).LT.tmp1 ) THEN
                  ie = j
                  tmp1 = w( j )
               END IF
  140       CONTINUE
            IF( ie.NE.0 ) THEN
               tmp2 = werr( ie )
               itmp1 = iblock( ie )
               itmp2 = indexw( ie )
               w( ie ) = w( je )
               werr( ie ) = werr( je )
               iblock( ie ) = iblock( je )
               indexw( ie ) = indexw( je )
               w( je ) = tmp1
               werr( je ) = tmp2
               iblock( je ) = itmp1
               indexw( je ) = itmp2
            END IF
  150    CONTINUE
      END IF
*
      info = 0
      IF( ncnvrg )
     $   info = info + 1
      IF( toofew )
     $   info = info + 2
      RETURN
*
*     End of DLARRD
*

dlarre()

subroutine dlarre	(	character	range,
		integer	n,
		double precision	vl,
		double precision	vu,
		integer	il,
		integer	iu,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( * )	e2,
		double precision	rtol1,
		double precision	rtol2,
		double precision	spltol,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	m,
		double precision, dimension( * )	w,
		double precision, dimension( * )	werr,
		double precision, dimension( * )	wgap,
		integer, dimension( * )	iblock,
		integer, dimension( * )	indexw,
		double precision, dimension( * )	gers,
		double precision	pivmin,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

DLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.

Download DLARRE + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> To find the desired eigenvalues of a given real symmetric
!> tridiagonal matrix T, DLARRE sets any  off-diagonal
!> elements to zero, and for each unreduced block T_i, it finds
!> (a) a suitable shift at one end of the block's spectrum,
!> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
!> (c) eigenvalues of each L_i D_i L_i^T.
!> The representations and eigenvalues found are then used by
!> DSTEMR to compute the eigenvectors of T.
!> The accuracy varies depending on whether bisection is used to
!> find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to
!> conpute all and then discard any unwanted one.
!> As an added benefit, DLARRE also outputs the n
!> Gerschgorin intervals for the matrices L_i D_i L_i^T.
!> 

Parameters

[in]	RANGE	!> RANGE is CHARACTER*1 !> = 'A': () all eigenvalues will be found. !> = 'V': () all eigenvalues in the half-open interval !> (VL, VU] will be found. !> = 'I': () the IL-th through IU-th eigenvalues (of the !> entire matrix) will be found. !>
[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in,out]	VL	!> VL is DOUBLE PRECISION !> If RANGE='V', the lower bound for the eigenvalues. !> Eigenvalues less than or equal to VL, or greater than VU, !> will not be returned. VL < VU. !> If RANGE='I' or ='A', DLARRE computes bounds on the desired !> part of the spectrum. !>
[in,out]	VU	!> VU is DOUBLE PRECISION !> If RANGE='V', the upper bound for the eigenvalues. !> Eigenvalues less than or equal to VL, or greater than VU, !> will not be returned. VL < VU. !> If RANGE='I' or ='A', DLARRE computes bounds on the desired !> part of the spectrum. !>
[in]	IL	!> IL is INTEGER !> If RANGE='I', the index of the !> smallest eigenvalue to be returned. !> 1 <= IL <= IU <= N. !>
[in]	IU	!> IU is INTEGER !> If RANGE='I', the index of the !> largest eigenvalue to be returned. !> 1 <= IL <= IU <= N. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension (N) !> On entry, the N diagonal elements of the tridiagonal !> matrix T. !> On exit, the N diagonal elements of the diagonal !> matrices D_i. !>
[in,out]	E	!> E is DOUBLE PRECISION array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) need not be set. !> On exit, E contains the subdiagonal elements of the unit !> bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, contain the base points sigma_i on output. !>
[in,out]	E2	!> E2 is DOUBLE PRECISION array, dimension (N) !> On entry, the first (N-1) entries contain the SQUARES of the !> subdiagonal elements of the tridiagonal matrix T; !> E2(N) need not be set. !> On exit, the entries E2( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, have been set to zero !>
[in]	RTOL1	!> RTOL1 is DOUBLE PRECISION !>
[in]	RTOL2	!> RTOL2 is DOUBLE PRECISION !> Parameters for bisection. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) !>
[in]	SPLTOL	!> SPLTOL is DOUBLE PRECISION !> The threshold for splitting. !>
[out]	NSPLIT	!> NSPLIT is INTEGER !> The number of blocks T splits into. 1 <= NSPLIT <= N. !>
[out]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into blocks. !> The first block consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !>
[out]	M	!> M is INTEGER !> The total number of eigenvalues (of all L_i D_i L_i^T) !> found. !>
[out]	W	!> W is DOUBLE PRECISION array, dimension (N) !> The first M elements contain the eigenvalues. The !> eigenvalues of each of the blocks, L_i D_i L_i^T, are !> sorted in ascending order ( DLARRE may use the !> remaining N-M elements as workspace). !>
[out]	WERR	!> WERR is DOUBLE PRECISION array, dimension (N) !> The error bound on the corresponding eigenvalue in W. !>
[out]	WGAP	!> WGAP is DOUBLE PRECISION array, dimension (N) !> The separation from the right neighbor eigenvalue in W. !> The gap is only with respect to the eigenvalues of the same block !> as each block has its own representation tree. !> Exception: at the right end of a block we store the left gap !>
[out]	IBLOCK	!> IBLOCK is INTEGER array, dimension (N) !> The indices of the blocks (submatrices) associated with the !> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue !> W(i) belongs to the first block from the top, =2 if W(i) !> belongs to the second block, etc. !>
[out]	INDEXW	!> INDEXW is INTEGER array, dimension (N) !> The indices of the eigenvalues within each block (submatrix); !> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the !> i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 !>
[out]	GERS	!> GERS is DOUBLE PRECISION array, dimension (2*N) !> The N Gerschgorin intervals (the i-th Gerschgorin interval !> is (GERS(2*i-1), GERS(2*i)). !>
[out]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot in the Sturm sequence for T. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (6*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (5*N) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> > 0: A problem occurred in DLARRE. !> < 0: One of the called subroutines signaled an internal problem. !> Needs inspection of the corresponding parameter IINFO !> for further information. !> !> =-1: Problem in DLARRD. !> = 2: No base representation could be found in MAXTRY iterations. !> Increasing MAXTRY and recompilation might be a remedy. !> =-3: Problem in DLARRB when computing the refined root !> representation for DLASQ2. !> =-4: Problem in DLARRB when preforming bisection on the !> desired part of the spectrum. !> =-5: Problem in DLASQ2. !> =-6: Problem in DLASQ2. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  The base representations are required to suffer very little
!>  element growth and consequently define all their eigenvalues to
!>  high relative accuracy.
!> 

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 301 of file dlarre.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      DOUBLE PRECISION  PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
     $                   INDEXW( * )
      DOUBLE PRECISION   D( * ), E( * ), E2( * ), GERS( * ),
     $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
      parameter( zero = 0.0d0, one = 1.0d0,
     $                     two = 2.0d0, four=4.0d0,
     $                     hndrd = 100.0d0,
     $                     pert = 8.0d0,
     $                     half = one/two, fourth = one/four, fac= half,
     $                     maxgrowth = 64.0d0, fudge = 2.0d0 )
      INTEGER            MAXTRY, ALLRNG, INDRNG, VALRNG
      parameter( maxtry = 6, allrng = 1, indrng = 2,
     $                     valrng = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FORCEB, NOREP, USEDQD
      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
     $                   WBEGIN, WEND
      DOUBLE PRECISION   AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
     $                   RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
     $                   TAU, TMP, TMP1
 
 
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION            DLAMCH
      EXTERNAL           dlamch, lsame
 
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlarnv, dlarra, dlarrb, dlarrc, dlarrd,
     $                   dlasq2, dlarrk
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
 
*     ..
*     .. Executable Statements ..
*
 
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Decode RANGE
*
      IF( lsame( range, 'A' ) ) THEN
         irange = allrng
      ELSE IF( lsame( range, 'V' ) ) THEN
         irange = valrng
      ELSE IF( lsame( range, 'I' ) ) THEN
         irange = indrng
      END IF
 
      m = 0
 
*     Get machine constants
      safmin = dlamch( 'S' )
      eps = dlamch( 'P' )
 
*     Set parameters
      rtl = sqrt(eps)
      bsrtol = sqrt(eps)
 
*     Treat case of 1x1 matrix for quick return
      IF( n.EQ.1 ) THEN
         IF( (irange.EQ.allrng).OR.
     $       ((irange.EQ.valrng).AND.(d(1).GT.vl).AND.(d(1).LE.vu)).OR.
     $       ((irange.EQ.indrng).AND.(il.EQ.1).AND.(iu.EQ.1)) ) THEN
            m = 1
            w(1) = d(1)
*           The computation error of the eigenvalue is zero
            werr(1) = zero
            wgap(1) = zero
            iblock( 1 ) = 1
            indexw( 1 ) = 1
            gers(1) = d( 1 )
            gers(2) = d( 1 )
         ENDIF
*        store the shift for the initial RRR, which is zero in this case
         e(1) = zero
         RETURN
      END IF
 
*     General case: tridiagonal matrix of order > 1
*
*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
*     Compute maximum off-diagonal entry and pivmin.
      gl = d(1)
      gu = d(1)
      eold = zero
      emax = zero
      e(n) = zero
      DO 5 i = 1,n
         werr(i) = zero
         wgap(i) = zero
         eabs = abs( e(i) )
         IF( eabs .GE. emax ) THEN
            emax = eabs
         END IF
         tmp1 = eabs + eold
         gers( 2*i-1) = d(i) - tmp1
         gl =  min( gl, gers( 2*i - 1))
         gers( 2*i ) = d(i) + tmp1
         gu = max( gu, gers(2*i) )
         eold  = eabs
 5    CONTINUE
*     The minimum pivot allowed in the Sturm sequence for T
      pivmin = safmin * max( one, emax**2 )
*     Compute spectral diameter. The Gerschgorin bounds give an
*     estimate that is wrong by at most a factor of SQRT(2)
      spdiam = gu - gl
 
*     Compute splitting points
      CALL dlarra( n, d, e, e2, spltol, spdiam,
     $                    nsplit, isplit, iinfo )
 
*     Can force use of bisection instead of faster DQDS.
*     Option left in the code for future multisection work.
      forceb = .false.
 
*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone
*     explicitly wants bisection.
      usedqd = (( irange.EQ.allrng ) .AND. (.NOT.forceb))
 
      IF( (irange.EQ.allrng) .AND. (.NOT. forceb) ) THEN
*        Set interval [VL,VU] that contains all eigenvalues
         vl = gl
         vu = gu
      ELSE
*        We call DLARRD to find crude approximations to the eigenvalues
*        in the desired range. In case IRANGE = INDRNG, we also obtain the
*        interval (VL,VU] that contains all the wanted eigenvalues.
*        An interval [LEFT,RIGHT] has converged if
*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
*        DLARRD needs a WORK of size 4*N, IWORK of size 3*N
         CALL dlarrd( range, 'B', n, vl, vu, il, iu, gers,
     $                    bsrtol, d, e, e2, pivmin, nsplit, isplit,
     $                    mm, w, werr, vl, vu, iblock, indexw,
     $                    work, iwork, iinfo )
         IF( iinfo.NE.0 ) THEN
            info = -1
            RETURN
         ENDIF
*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
         DO 14 i = mm+1,n
            w( i ) = zero
            werr( i ) = zero
            iblock( i ) = 0
            indexw( i ) = 0
 14      CONTINUE
      END IF
 
 
***
*     Loop over unreduced blocks
      ibegin = 1
      wbegin = 1
      DO 170 jblk = 1, nsplit
         iend = isplit( jblk )
         in = iend - ibegin + 1
 
*        1 X 1 block
         IF( in.EQ.1 ) THEN
            IF( (irange.EQ.allrng).OR.( (irange.EQ.valrng).AND.
     $         ( d( ibegin ).GT.vl ).AND.( d( ibegin ).LE.vu ) )
     $        .OR. ( (irange.EQ.indrng).AND.(iblock(wbegin).EQ.jblk))
     $        ) THEN
               m = m + 1
               w( m ) = d( ibegin )
               werr(m) = zero
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               wgap(m) = zero
               iblock( m ) = jblk
               indexw( m ) = 1
               wbegin = wbegin + 1
            ENDIF
*           E( IEND ) holds the shift for the initial RRR
            e( iend ) = zero
            ibegin = iend + 1
            GO TO 170
         END IF
*
*        Blocks of size larger than 1x1
*
*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
         e( iend ) = zero
*
*        Find local outer bounds GL,GU for the block
         gl = d(ibegin)
         gu = d(ibegin)
         DO 15 i = ibegin , iend
            gl = min( gers( 2*i-1 ), gl )
            gu = max( gers( 2*i ), gu )
 15      CONTINUE
         spdiam = gu - gl
 
         IF(.NOT. ((irange.EQ.allrng).AND.(.NOT.forceb)) ) THEN
*           Count the number of eigenvalues in the current block.
            mb = 0
            DO 20 i = wbegin,mm
               IF( iblock(i).EQ.jblk ) THEN
                  mb = mb+1
               ELSE
                  GOTO 21
               ENDIF
 20         CONTINUE
 21         CONTINUE
 
            IF( mb.EQ.0) THEN
*              No eigenvalue in the current block lies in the desired range
*              E( IEND ) holds the shift for the initial RRR
               e( iend ) = zero
               ibegin = iend + 1
               GO TO 170
            ELSE
 
*              Decide whether dqds or bisection is more efficient
               usedqd = ( (mb .GT. fac*in) .AND. (.NOT.forceb) )
               wend = wbegin + mb - 1
*              Calculate gaps for the current block
*              In later stages, when representations for individual
*              eigenvalues are different, we use SIGMA = E( IEND ).
               sigma = zero
               DO 30 i = wbegin, wend - 1
                  wgap( i ) = max( zero,
     $                        w(i+1)-werr(i+1) - (w(i)+werr(i)) )
 30            CONTINUE
               wgap( wend ) = max( zero,
     $                     vu - sigma - (w( wend )+werr( wend )))
*              Find local index of the first and last desired evalue.
               indl = indexw(wbegin)
               indu = indexw( wend )
            ENDIF
         ENDIF
         IF(( (irange.EQ.allrng) .AND. (.NOT. forceb) ).OR.usedqd) THEN
*           Case of DQDS
*           Find approximations to the extremal eigenvalues of the block
            CALL dlarrk( in, 1, gl, gu, d(ibegin),
     $               e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
            IF( iinfo.NE.0 ) THEN
               info = -1
               RETURN
            ENDIF
            isleft = max(gl, tmp - tmp1
     $               - hndrd * eps* abs(tmp - tmp1))
 
            CALL dlarrk( in, in, gl, gu, d(ibegin),
     $               e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
            IF( iinfo.NE.0 ) THEN
               info = -1
               RETURN
            ENDIF
            isrght = min(gu, tmp + tmp1
     $                 + hndrd * eps * abs(tmp + tmp1))
*           Improve the estimate of the spectral diameter
            spdiam = isrght - isleft
         ELSE
*           Case of bisection
*           Find approximations to the wanted extremal eigenvalues
            isleft = max(gl, w(wbegin) - werr(wbegin)
     $                  - hndrd * eps*abs(w(wbegin)- werr(wbegin) ))
            isrght = min(gu,w(wend) + werr(wend)
     $                  + hndrd * eps * abs(w(wend)+ werr(wend)))
         ENDIF
 
 
*        Decide whether the base representation for the current block
*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
*        should be on the left or the right end of the current block.
*        The strategy is to shift to the end which is "more populated"
*        Furthermore, decide whether to use DQDS for the computation of
*        the eigenvalue approximations at the end of DLARRE or bisection.
*        dqds is chosen if all eigenvalues are desired or the number of
*        eigenvalues to be computed is large compared to the blocksize.
         IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
*           If all the eigenvalues have to be computed, we use dqd
            usedqd = .true.
*           INDL is the local index of the first eigenvalue to compute
            indl = 1
            indu = in
*           MB =  number of eigenvalues to compute
            mb = in
            wend = wbegin + mb - 1
*           Define 1/4 and 3/4 points of the spectrum
            s1 = isleft + fourth * spdiam
            s2 = isrght - fourth * spdiam
         ELSE
*           DLARRD has computed IBLOCK and INDEXW for each eigenvalue
*           approximation.
*           choose sigma
            IF( usedqd ) THEN
               s1 = isleft + fourth * spdiam
               s2 = isrght - fourth * spdiam
            ELSE
               tmp = min(isrght,vu) -  max(isleft,vl)
               s1 =  max(isleft,vl) + fourth * tmp
               s2 =  min(isrght,vu) - fourth * tmp
            ENDIF
         ENDIF
 
*        Compute the negcount at the 1/4 and 3/4 points
         IF(mb.GT.1) THEN
            CALL dlarrc( 'T', in, s1, s2, d(ibegin),
     $                    e(ibegin), pivmin, cnt, cnt1, cnt2, iinfo)
         ENDIF
 
         IF(mb.EQ.1) THEN
            sigma = gl
            sgndef = one
         ELSEIF( cnt1 - indl .GE. indu - cnt2 ) THEN
            IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
               sigma = max(isleft,gl)
            ELSEIF( usedqd ) THEN
*              use Gerschgorin bound as shift to get pos def matrix
*              for dqds
               sigma = isleft
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               sigma = max(isleft,vl)
            ENDIF
            sgndef = one
         ELSE
            IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
               sigma = min(isrght,gu)
            ELSEIF( usedqd ) THEN
*              use Gerschgorin bound as shift to get neg def matrix
*              for dqds
               sigma = isrght
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               sigma = min(isrght,vu)
            ENDIF
            sgndef = -one
         ENDIF
 
 
*        An initial SIGMA has been chosen that will be used for computing
*        T - SIGMA I = L D L^T
*        Define the increment TAU of the shift in case the initial shift
*        needs to be refined to obtain a factorization with not too much
*        element growth.
         IF( usedqd ) THEN
*           The initial SIGMA was to the outer end of the spectrum
*           the matrix is definite and we need not retreat.
            tau = spdiam*eps*n + two*pivmin
            tau = max( tau,two*eps*abs(sigma) )
         ELSE
            IF(mb.GT.1) THEN
               clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin)
               avgap = abs(clwdth / dble(wend-wbegin))
               IF( sgndef.EQ.one ) THEN
                  tau = half*max(wgap(wbegin),avgap)
                  tau = max(tau,werr(wbegin))
               ELSE
                  tau = half*max(wgap(wend-1),avgap)
                  tau = max(tau,werr(wend))
               ENDIF
            ELSE
               tau = werr(wbegin)
            ENDIF
         ENDIF
*
         DO 80 idum = 1, maxtry
*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
*           pivots in WORK(2*IN+1:3*IN)
            dpivot = d( ibegin ) - sigma
            work( 1 ) = dpivot
            dmax = abs( work(1) )
            j = ibegin
            DO 70 i = 1, in - 1
               work( 2*in+i ) = one / work( i )
               tmp = e( j )*work( 2*in+i )
               work( in+i ) = tmp
               dpivot = ( d( j+1 )-sigma ) - tmp*e( j )
               work( i+1 ) = dpivot
               dmax = max( dmax, abs(dpivot) )
               j = j + 1
 70         CONTINUE
*           check for element growth
            IF( dmax .GT. maxgrowth*spdiam ) THEN
               norep = .true.
            ELSE
               norep = .false.
            ENDIF
            IF( usedqd .AND. .NOT.norep ) THEN
*              Ensure the definiteness of the representation
*              All entries of D (of L D L^T) must have the same sign
               DO 71 i = 1, in
                  tmp = sgndef*work( i )
                  IF( tmp.LT.zero ) norep = .true.
 71            CONTINUE
            ENDIF
            IF(norep) THEN
*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
*              shift which makes the matrix definite. So we should end up
*              here really only in the case of IRANGE = VALRNG or INDRNG.
               IF( idum.EQ.maxtry-1 ) THEN
                  IF( sgndef.EQ.one ) THEN
*                    The fudged Gerschgorin shift should succeed
                     sigma =
     $                    gl - fudge*spdiam*eps*n - fudge*two*pivmin
                  ELSE
                     sigma =
     $                    gu + fudge*spdiam*eps*n + fudge*two*pivmin
                  END IF
               ELSE
                  sigma = sigma - sgndef * tau
                  tau = two * tau
               END IF
            ELSE
*              an initial RRR is found
               GO TO 83
            END IF
 80      CONTINUE
*        if the program reaches this point, no base representation could be
*        found in MAXTRY iterations.
         info = 2
         RETURN
 
 83      CONTINUE
*        At this point, we have found an initial base representation
*        T - SIGMA I = L D L^T with not too much element growth.
*        Store the shift.
         e( iend ) = sigma
*        Store D and L.
         CALL dcopy( in, work, 1, d( ibegin ), 1 )
         CALL dcopy( in-1, work( in+1 ), 1, e( ibegin ), 1 )
 
 
         IF(mb.GT.1 ) THEN
*
*           Perturb each entry of the base representation by a small
*           (but random) relative amount to overcome difficulties with
*           glued matrices.
*
            DO 122 i = 1, 4
               iseed( i ) = 1
 122        CONTINUE
 
            CALL dlarnv(2, iseed, 2*in-1, work(1))
            DO 125 i = 1,in-1
               d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i))
               e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i))
 125        CONTINUE
            d(iend) = d(iend)*(one+eps*four*work(in))
*
         ENDIF
*
*        Don't update the Gerschgorin intervals because keeping track
*        of the updates would be too much work in DLARRV.
*        We update W instead and use it to locate the proper Gerschgorin
*        intervals.
 
*        Compute the required eigenvalues of L D L' by bisection or dqds
         IF ( .NOT.usedqd ) THEN
*           If DLARRD has been used, shift the eigenvalue approximations
*           according to their representation. This is necessary for
*           a uniform DLARRV since dqds computes eigenvalues of the
*           shifted representation. In DLARRV, W will always hold the
*           UNshifted eigenvalue approximation.
            DO 134 j=wbegin,wend
               w(j) = w(j) - sigma
               werr(j) = werr(j) + abs(w(j)) * eps
 134        CONTINUE
*           call DLARRB to reduce eigenvalue error of the approximations
*           from DLARRD
            DO 135 i = ibegin, iend-1
               work( i ) = d( i ) * e( i )**2
 135        CONTINUE
*           use bisection to find EV from INDL to INDU
            CALL dlarrb(in, d(ibegin), work(ibegin),
     $                  indl, indu, rtol1, rtol2, indl-1,
     $                  w(wbegin), wgap(wbegin), werr(wbegin),
     $                  work( 2*n+1 ), iwork, pivmin, spdiam,
     $                  in, iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = -4
               RETURN
            END IF
*           DLARRB computes all gaps correctly except for the last one
*           Record distance to VU/GU
            wgap( wend ) = max( zero,
     $           ( vu-sigma ) - ( w( wend ) + werr( wend ) ) )
            DO 138 i = indl, indu
               m = m + 1
               iblock(m) = jblk
               indexw(m) = i
 138        CONTINUE
         ELSE
*           Call dqds to get all eigs (and then possibly delete unwanted
*           eigenvalues).
*           Note that dqds finds the eigenvalues of the L D L^T representation
*           of T to high relative accuracy. High relative accuracy
*           might be lost when the shift of the RRR is subtracted to obtain
*           the eigenvalues of T. However, T is not guaranteed to define its
*           eigenvalues to high relative accuracy anyway.
*           Set RTOL to the order of the tolerance used in DLASQ2
*           This is an ESTIMATED error, the worst case bound is 4*N*EPS
*           which is usually too large and requires unnecessary work to be
*           done by bisection when computing the eigenvectors
            rtol = log(dble(in)) * four * eps
            j = ibegin
            DO 140 i = 1, in - 1
               work( 2*i-1 ) = abs( d( j ) )
               work( 2*i ) = e( j )*e( j )*work( 2*i-1 )
               j = j + 1
  140       CONTINUE
            work( 2*in-1 ) = abs( d( iend ) )
            work( 2*in ) = zero
            CALL dlasq2( in, work, iinfo )
            IF( iinfo .NE. 0 ) THEN
*              If IINFO = -5 then an index is part of a tight cluster
*              and should be changed. The index is in IWORK(1) and the
*              gap is in WORK(N+1)
               info = -5
               RETURN
            ELSE
*              Test that all eigenvalues are positive as expected
               DO 149 i = 1, in
                  IF( work( i ).LT.zero ) THEN
                     info = -6
                     RETURN
                  ENDIF
 149           CONTINUE
            END IF
            IF( sgndef.GT.zero ) THEN
               DO 150 i = indl, indu
                  m = m + 1
                  w( m ) = work( in-i+1 )
                  iblock( m ) = jblk
                  indexw( m ) = i
 150           CONTINUE
            ELSE
               DO 160 i = indl, indu
                  m = m + 1
                  w( m ) = -work( i )
                  iblock( m ) = jblk
                  indexw( m ) = i
 160           CONTINUE
            END IF
 
            DO 165 i = m - mb + 1, m
*              the value of RTOL below should be the tolerance in DLASQ2
               werr( i ) = rtol * abs( w(i) )
 165        CONTINUE
            DO 166 i = m - mb + 1, m - 1
*              compute the right gap between the intervals
               wgap( i ) = max( zero,
     $                          w(i+1)-werr(i+1) - (w(i)+werr(i)) )
 166        CONTINUE
            wgap( m ) = max( zero,
     $           ( vu-sigma ) - ( w( m ) + werr( m ) ) )
         END IF
*        proceed with next block
         ibegin = iend + 1
         wbegin = wend + 1
 170  CONTINUE
*
 
      RETURN
*
*     End of DLARRE
*

dlarrf()

subroutine dlarrf	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	l,
		double precision, dimension( * )	ld,
		integer	clstrt,
		integer	clend,
		double precision, dimension( * )	w,
		double precision, dimension( * )	wgap,
		double precision, dimension( * )	werr,
		double precision	spdiam,
		double precision	clgapl,
		double precision	clgapr,
		double precision	pivmin,
		double precision	sigma,
		double precision, dimension( * )	dplus,
		double precision, dimension( * )	lplus,
		double precision, dimension( * )	work,
		integer	info )

DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated.

Download DLARRF + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the initial representation L D L^T and its cluster of close
!> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
!> W( CLEND ), DLARRF finds a new relatively robust representation
!> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
!> eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix (subblock, if the matrix split). !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	L	!> L is DOUBLE PRECISION array, dimension (N-1) !> The (N-1) subdiagonal elements of the unit bidiagonal !> matrix L. !>
[in]	LD	!> LD is DOUBLE PRECISION array, dimension (N-1) !> The (N-1) elements L(i)*D(i). !>
[in]	CLSTRT	!> CLSTRT is INTEGER !> The index of the first eigenvalue in the cluster. !>
[in]	CLEND	!> CLEND is INTEGER !> The index of the last eigenvalue in the cluster. !>
[in]	W	!> W is DOUBLE PRECISION array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> The eigenvalue APPROXIMATIONS of L D L^T in ascending order. !> W( CLSTRT ) through W( CLEND ) form the cluster of relatively !> close eigenalues. !>
[in,out]	WGAP	!> WGAP is DOUBLE PRECISION array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> The separation from the right neighbor eigenvalue in W. !>
[in]	WERR	!> WERR is DOUBLE PRECISION array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> WERR contain the semiwidth of the uncertainty !> interval of the corresponding eigenvalue APPROXIMATION in W !>
[in]	SPDIAM	!> SPDIAM is DOUBLE PRECISION !> estimate of the spectral diameter obtained from the !> Gerschgorin intervals !>
[in]	CLGAPL	!> CLGAPL is DOUBLE PRECISION !>
[in]	CLGAPR	!> CLGAPR is DOUBLE PRECISION !> absolute gap on each end of the cluster. !> Set by the calling routine to protect against shifts too close !> to eigenvalues outside the cluster. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot allowed in the Sturm sequence. !>
[out]	SIGMA	!> SIGMA is DOUBLE PRECISION !> The shift used to form L(+) D(+) L(+)^T. !>
[out]	DPLUS	!> DPLUS is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of the diagonal matrix D(+). !>
[out]	LPLUS	!> LPLUS is DOUBLE PRECISION array, dimension (N-1) !> The first (N-1) elements of LPLUS contain the subdiagonal !> elements of the unit bidiagonal matrix L(+). !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (2*N) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> Signals processing OK (=0) or failure (=1) !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 189 of file dlarrf.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            CLSTRT, CLEND, INFO, N
      DOUBLE PRECISION   CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DPLUS( * ), L( * ), LD( * ),
     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
      parameter( one = 1.0d0, two = 2.0d0, four = 4.0d0,
     $                     quart = 0.25d0,
     $                     maxgrowth1 = 8.d0,
     $                     maxgrowth2 = 8.d0 )
*     ..
*     .. Local Scalars ..
      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
      parameter( ktrymax = 1, sleft = 1, sright = 2 )
      DOUBLE PRECISION   AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
     $                   FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
     $                   MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
     $                   RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
*     ..
*     .. External Functions ..
      LOGICAL DISNAN
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           disnan, dlamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      fact = dble(2**ktrymax)
      eps = dlamch( 'Precision' )
      shift = 0
      forcer = .false.
 
 
*     Note that we cannot guarantee that for any of the shifts tried,
*     the factorization has a small or even moderate element growth.
*     There could be Ritz values at both ends of the cluster and despite
*     backing off, there are examples where all factorizations tried
*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
*     element growth.
*     For this reason, we should use PIVMIN in this subroutine so that at
*     least the L D L^T factorization exists. It can be checked afterwards
*     whether the element growth caused bad residuals/orthogonality.
 
*     Decide whether the code should accept the best among all
*     representations despite large element growth or signal INFO=1
*     Setting NOFAIL to .FALSE. for quick fix for bug 113
      nofail = .false.
*
 
*     Compute the average gap length of the cluster
      clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt)
      avgap = clwdth / dble(clend-clstrt)
      mingap = min(clgapl, clgapr)
*     Initial values for shifts to both ends of cluster
      lsigma = min(w( clstrt ),w( clend )) - werr( clstrt )
      rsigma = max(w( clstrt ),w( clend )) + werr( clend )
 
*     Use a small fudge to make sure that we really shift to the outside
      lsigma = lsigma - abs(lsigma)* four * eps
      rsigma = rsigma + abs(rsigma)* four * eps
 
*     Compute upper bounds for how much to back off the initial shifts
      ldmax = quart * mingap + two * pivmin
      rdmax = quart * mingap + two * pivmin
 
      ldelta = max(avgap,wgap( clstrt ))/fact
      rdelta = max(avgap,wgap( clend-1 ))/fact
*
*     Initialize the record of the best representation found
*
      s = dlamch( 'S' )
      smlgrowth = one / s
      fail = dble(n-1)*mingap/(spdiam*eps)
      fail2 = dble(n-1)*mingap/(spdiam*sqrt(eps))
      bestshift = lsigma
*
*     while (KTRY <= KTRYMAX)
      ktry = 0
      growthbound = maxgrowth1*spdiam
 
 5    CONTINUE
      sawnan1 = .false.
      sawnan2 = .false.
*     Ensure that we do not back off too much of the initial shifts
      ldelta = min(ldmax,ldelta)
      rdelta = min(rdmax,rdelta)
 
*     Compute the element growth when shifting to both ends of the cluster
*     accept the shift if there is no element growth at one of the two ends
 
*     Left end
      s = -lsigma
      dplus( 1 ) = d( 1 ) + s
      IF(abs(dplus(1)).LT.pivmin) THEN
         dplus(1) = -pivmin
*        Need to set SAWNAN1 because refined RRR test should not be used
*        in this case
         sawnan1 = .true.
      ENDIF
      max1 = abs( dplus( 1 ) )
      DO 6 i = 1, n - 1
         lplus( i ) = ld( i ) / dplus( i )
         s = s*lplus( i )*l( i ) - lsigma
         dplus( i+1 ) = d( i+1 ) + s
         IF(abs(dplus(i+1)).LT.pivmin) THEN
            dplus(i+1) = -pivmin
*           Need to set SAWNAN1 because refined RRR test should not be used
*           in this case
            sawnan1 = .true.
         ENDIF
         max1 = max( max1,abs(dplus(i+1)) )
 6    CONTINUE
      sawnan1 = sawnan1 .OR.  disnan( max1 )
 
      IF( forcer .OR.
     $   (max1.LE.growthbound .AND. .NOT.sawnan1 ) ) THEN
         sigma = lsigma
         shift = sleft
         GOTO 100
      ENDIF
 
*     Right end
      s = -rsigma
      work( 1 ) = d( 1 ) + s
      IF(abs(work(1)).LT.pivmin) THEN
         work(1) = -pivmin
*        Need to set SAWNAN2 because refined RRR test should not be used
*        in this case
         sawnan2 = .true.
      ENDIF
      max2 = abs( work( 1 ) )
      DO 7 i = 1, n - 1
         work( n+i ) = ld( i ) / work( i )
         s = s*work( n+i )*l( i ) - rsigma
         work( i+1 ) = d( i+1 ) + s
         IF(abs(work(i+1)).LT.pivmin) THEN
            work(i+1) = -pivmin
*           Need to set SAWNAN2 because refined RRR test should not be used
*           in this case
            sawnan2 = .true.
         ENDIF
         max2 = max( max2,abs(work(i+1)) )
 7    CONTINUE
      sawnan2 = sawnan2 .OR.  disnan( max2 )
 
      IF( forcer .OR.
     $   (max2.LE.growthbound .AND. .NOT.sawnan2 ) ) THEN
         sigma = rsigma
         shift = sright
         GOTO 100
      ENDIF
*     If we are at this point, both shifts led to too much element growth
 
*     Record the better of the two shifts (provided it didn't lead to NaN)
      IF(sawnan1.AND.sawnan2) THEN
*        both MAX1 and MAX2 are NaN
         GOTO 50
      ELSE
         IF( .NOT.sawnan1 ) THEN
            indx = 1
            IF(max1.LE.smlgrowth) THEN
               smlgrowth = max1
               bestshift = lsigma
            ENDIF
         ENDIF
         IF( .NOT.sawnan2 ) THEN
            IF(sawnan1 .OR. max2.LE.max1) indx = 2
            IF(max2.LE.smlgrowth) THEN
               smlgrowth = max2
               bestshift = rsigma
            ENDIF
         ENDIF
      ENDIF
 
*     If we are here, both the left and the right shift led to
*     element growth. If the element growth is moderate, then
*     we may still accept the representation, if it passes a
*     refined test for RRR. This test supposes that no NaN occurred.
*     Moreover, we use the refined RRR test only for isolated clusters.
      IF((clwdth.LT.mingap/dble(128)) .AND.
     $   (min(max1,max2).LT.fail2)
     $  .AND.(.NOT.sawnan1).AND.(.NOT.sawnan2)) THEN
         dorrr1 = .true.
      ELSE
         dorrr1 = .false.
      ENDIF
      tryrrr1 = .true.
      IF( tryrrr1 .AND. dorrr1 ) THEN
      IF(indx.EQ.1) THEN
         tmp = abs( dplus( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 15 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod =
     $         ((dplus(i+1)*work(n+i+1))/(dplus(i)*work(n+i)))*oldp
            ELSE
               prod = prod*abs(work(n+i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( dplus( i ) * prod ))
 15      CONTINUE
         rrr1 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr1.LE.maxgrowth2) THEN
            sigma = lsigma
            shift = sleft
            GOTO 100
         ENDIF
      ELSE IF(indx.EQ.2) THEN
         tmp = abs( work( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 16 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod = ((work(i+1)*lplus(i+1))/(work(i)*lplus(i)))*oldp
            ELSE
               prod = prod*abs(lplus(i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( work( i ) * prod ))
 16      CONTINUE
         rrr2 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr2.LE.maxgrowth2) THEN
            sigma = rsigma
            shift = sright
            GOTO 100
         ENDIF
      END IF
      ENDIF
 
 50   CONTINUE
 
      IF (ktry.LT.ktrymax) THEN
*        If we are here, both shifts failed also the RRR test.
*        Back off to the outside
         lsigma = max( lsigma - ldelta,
     $     lsigma - ldmax)
         rsigma = min( rsigma + rdelta,
     $     rsigma + rdmax )
         ldelta = two * ldelta
         rdelta = two * rdelta
         ktry = ktry + 1
         GOTO 5
      ELSE
*        None of the representations investigated satisfied our
*        criteria. Take the best one we found.
         IF((smlgrowth.LT.fail).OR.nofail) THEN
            lsigma = bestshift
            rsigma = bestshift
            forcer = .true.
            GOTO 5
         ELSE
            info = 1
            RETURN
         ENDIF
      END IF
 
 100  CONTINUE
      IF (shift.EQ.sleft) THEN
      ELSEIF (shift.EQ.sright) THEN
*        store new L and D back into DPLUS, LPLUS
         CALL dcopy( n, work, 1, dplus, 1 )
         CALL dcopy( n-1, work(n+1), 1, lplus, 1 )
      ENDIF
 
      RETURN
*
*     End of DLARRF
*

dlarrj()

subroutine dlarrj	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e2,
		integer	ifirst,
		integer	ilast,
		double precision	rtol,
		integer	offset,
		double precision, dimension( * )	w,
		double precision, dimension( * )	werr,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		double precision	pivmin,
		double precision	spdiam,
		integer	info )

DLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.

Download DLARRJ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the initial eigenvalue approximations of T, DLARRJ
!> does  bisection to refine the eigenvalues of T,
!> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
!> guesses for these eigenvalues are input in W, the corresponding estimate
!> of the error in these guesses in WERR. During bisection, intervals
!> [left, right] are maintained by storing their mid-points and
!> semi-widths in the arrays W and WERR respectively.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of T. !>
[in]	E2	!> E2 is DOUBLE PRECISION array, dimension (N-1) !> The Squares of the (N-1) subdiagonal elements of T. !>
[in]	IFIRST	!> IFIRST is INTEGER !> The index of the first eigenvalue to be computed. !>
[in]	ILAST	!> ILAST is INTEGER !> The index of the last eigenvalue to be computed. !>
[in]	RTOL	!> RTOL is DOUBLE PRECISION !> Tolerance for the convergence of the bisection intervals. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < RTOL*MAX(|LEFT|,|RIGHT|). !>
[in]	OFFSET	!> OFFSET is INTEGER !> Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET !> through ILAST-OFFSET elements of these arrays are to be used. !>
[in,out]	W	!> W is DOUBLE PRECISION array, dimension (N) !> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are !> estimates of the eigenvalues of L D L^T indexed IFIRST through !> ILAST. !> On output, these estimates are refined. !>
[in,out]	WERR	!> WERR is DOUBLE PRECISION array, dimension (N) !> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are !> the errors in the estimates of the corresponding elements in W. !> On output, these errors are refined. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (2*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (2*N) !> Workspace. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot in the Sturm sequence for T. !>
[in]	SPDIAM	!> SPDIAM is DOUBLE PRECISION !> The spectral diameter of T. !>
[out]	INFO	!> INFO is INTEGER !> Error flag. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 165 of file dlarrj.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N, OFFSET
      DOUBLE PRECISION   PIVMIN, RTOL, SPDIAM
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E2( * ), W( * ),
     $                   WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, HALF
      parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
     $                   half = 0.5d0 )
      INTEGER   MAXITR
*     ..
*     .. Local Scalars ..
      INTEGER            CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
     $                   OLNINT, P, PREV, SAVI1
      DOUBLE PRECISION   DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
*
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
*
*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
*     for an unconverged interval is set to the index of the next unconverged
*     interval, and is -1 or 0 for a converged interval. Thus a linked
*     list of unconverged intervals is set up.
*
 
      i1 = ifirst
      i2 = ilast
*     The number of unconverged intervals
      nint = 0
*     The last unconverged interval found
      prev = 0
      DO 75 i = i1, i2
         k = 2*i
         ii = i - offset
         left = w( ii ) - werr( ii )
         mid = w(ii)
         right = w( ii ) + werr( ii )
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
 
*        The following test prevents the test of converged intervals
         IF( width.LT.rtol*tmp ) THEN
*           This interval has already converged and does not need refinement.
*           (Note that the gaps might change through refining the
*            eigenvalues, however, they can only get bigger.)
*           Remove it from the list.
            iwork( k-1 ) = -1
*           Make sure that I1 always points to the first unconverged interval
            IF((i.EQ.i1).AND.(i.LT.i2)) i1 = i + 1
            IF((prev.GE.i1).AND.(i.LE.i2)) iwork( 2*prev-1 ) = i + 1
         ELSE
*           unconverged interval found
            prev = i
*           Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*
*           Do while( CNT(LEFT).GT.I-1 )
*
            fac = one
 20         CONTINUE
            cnt = 0
            s = left
            dplus = d( 1 ) - s
            IF( dplus.LT.zero ) cnt = cnt + 1
            DO 30 j = 2, n
               dplus = d( j ) - s - e2( j-1 )/dplus
               IF( dplus.LT.zero ) cnt = cnt + 1
 30         CONTINUE
            IF( cnt.GT.i-1 ) THEN
               left = left - werr( ii )*fac
               fac = two*fac
               GO TO 20
            END IF
*
*           Do while( CNT(RIGHT).LT.I )
*
            fac = one
 50         CONTINUE
            cnt = 0
            s = right
            dplus = d( 1 ) - s
            IF( dplus.LT.zero ) cnt = cnt + 1
            DO 60 j = 2, n
               dplus = d( j ) - s - e2( j-1 )/dplus
               IF( dplus.LT.zero ) cnt = cnt + 1
 60         CONTINUE
            IF( cnt.LT.i ) THEN
               right = right + werr( ii )*fac
               fac = two*fac
               GO TO 50
            END IF
            nint = nint + 1
            iwork( k-1 ) = i + 1
            iwork( k ) = cnt
         END IF
         work( k-1 ) = left
         work( k ) = right
 75   CONTINUE
 
 
      savi1 = i1
*
*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
*     and while (ITER.LT.MAXITR)
*
      iter = 0
 80   CONTINUE
      prev = i1 - 1
      i = i1
      olnint = nint
 
      DO 100 p = 1, olnint
         k = 2*i
         ii = i - offset
         next = iwork( k-1 )
         left = work( k-1 )
         right = work( k )
         mid = half*( left + right )
 
*        semiwidth of interval
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
 
         IF( ( width.LT.rtol*tmp ) .OR.
     $      (iter.EQ.maxitr) )THEN
*           reduce number of unconverged intervals
            nint = nint - 1
*           Mark interval as converged.
            iwork( k-1 ) = 0
            IF( i1.EQ.i ) THEN
               i1 = next
            ELSE
*              Prev holds the last unconverged interval previously examined
               IF(prev.GE.i1) iwork( 2*prev-1 ) = next
            END IF
            i = next
            GO TO 100
         END IF
         prev = i
*
*        Perform one bisection step
*
         cnt = 0
         s = mid
         dplus = d( 1 ) - s
         IF( dplus.LT.zero ) cnt = cnt + 1
         DO 90 j = 2, n
            dplus = d( j ) - s - e2( j-1 )/dplus
            IF( dplus.LT.zero ) cnt = cnt + 1
 90      CONTINUE
         IF( cnt.LE.i-1 ) THEN
            work( k-1 ) = mid
         ELSE
            work( k ) = mid
         END IF
         i = next
 
 100  CONTINUE
      iter = iter + 1
*     do another loop if there are still unconverged intervals
*     However, in the last iteration, all intervals are accepted
*     since this is the best we can do.
      IF( ( nint.GT.0 ).AND.(iter.LE.maxitr) ) GO TO 80
*
*
*     At this point, all the intervals have converged
      DO 110 i = savi1, ilast
         k = 2*i
         ii = i - offset
*        All intervals marked by '0' have been refined.
         IF( iwork( k-1 ).EQ.0 ) THEN
            w( ii ) = half*( work( k-1 )+work( k ) )
            werr( ii ) = work( k ) - w( ii )
         END IF
 110  CONTINUE
*
 
      RETURN
*
*     End of DLARRJ
*

dlarrk()

subroutine dlarrk	(	integer	n,
		integer	iw,
		double precision	gl,
		double precision	gu,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e2,
		double precision	pivmin,
		double precision	reltol,
		double precision	w,
		double precision	werr,
		integer	info )

DLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy.

Download DLARRK + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARRK computes one eigenvalue of a symmetric tridiagonal
!> matrix T to suitable accuracy. This is an auxiliary code to be
!> called from DSTEMR.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the tridiagonal matrix T. N >= 0. !>
[in]	IW	!> IW is INTEGER !> The index of the eigenvalues to be returned. !>
[in]	GL	!> GL is DOUBLE PRECISION !>
[in]	GU	!> GU is DOUBLE PRECISION !> An upper and a lower bound on the eigenvalue. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The n diagonal elements of the tridiagonal matrix T. !>
[in]	E2	!> E2 is DOUBLE PRECISION array, dimension (N-1) !> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. !>
[in]	PIVMIN	!> PIVMIN is DOUBLE PRECISION !> The minimum pivot allowed in the Sturm sequence for T. !>
[in]	RELTOL	!> RELTOL is DOUBLE PRECISION !> The minimum relative width of an interval. When an interval !> is narrower than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[out]	W	!> W is DOUBLE PRECISION !>
[out]	WERR	!> WERR is DOUBLE PRECISION !> The error bound on the corresponding eigenvalue approximation !> in W. !>
[out]	INFO	!> INFO is INTEGER !> = 0: Eigenvalue converged !> = -1: Eigenvalue did NOT converge !>

Internal Parameters:

!>  FUDGE   DOUBLE PRECISION, default = 2
!>          A  to widen the Gershgorin intervals.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 143 of file dlarrk.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER   INFO, IW, N
      DOUBLE PRECISION    PIVMIN, RELTOL, GL, GU, W, WERR
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   FUDGE, HALF, TWO, ZERO
      parameter( half = 0.5d0, two = 2.0d0,
     $                     fudge = two, zero = 0.0d0 )
*     ..
*     .. Local Scalars ..
      INTEGER   I, IT, ITMAX, NEGCNT
      DOUBLE PRECISION   ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
     $                   TMP2, TNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL   dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         info = 0
         RETURN
      END IF
*
*     Get machine constants
      eps = dlamch( 'P' )
 
      tnorm = max( abs( gl ), abs( gu ) )
      rtoli = reltol
      atoli = fudge*two*pivmin
 
      itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
 
      info = -1
 
      left = gl - fudge*tnorm*eps*n - fudge*two*pivmin
      right = gu + fudge*tnorm*eps*n + fudge*two*pivmin
      it = 0
 
 10   CONTINUE
*
*     Check if interval converged or maximum number of iterations reached
*
      tmp1 = abs( right - left )
      tmp2 = max( abs(right), abs(left) )
      IF( tmp1.LT.max( atoli, pivmin, rtoli*tmp2 ) ) THEN
         info = 0
         GOTO 30
      ENDIF
      IF(it.GT.itmax)
     $   GOTO 30
 
*
*     Count number of negative pivots for mid-point
*
      it = it + 1
      mid = half * (left + right)
      negcnt = 0
      tmp1 = d( 1 ) - mid
      IF( abs( tmp1 ).LT.pivmin )
     $   tmp1 = -pivmin
      IF( tmp1.LE.zero )
     $   negcnt = negcnt + 1
*
      DO 20 i = 2, n
         tmp1 = d( i ) - e2( i-1 ) / tmp1 - mid
         IF( abs( tmp1 ).LT.pivmin )
     $      tmp1 = -pivmin
         IF( tmp1.LE.zero )
     $      negcnt = negcnt + 1
 20   CONTINUE
 
      IF(negcnt.GE.iw) THEN
         right = mid
      ELSE
         left = mid
      ENDIF
      GOTO 10
 
 30   CONTINUE
*
*     Converged or maximum number of iterations reached
*
      w = half * (left + right)
      werr = half * abs( right - left )
 
      RETURN
*
*     End of DLARRK
*

dlarrr()

subroutine dlarrr	(	integer	n,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		integer	info )

DLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues.

Download DLARRR + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Perform tests to decide whether the symmetric tridiagonal matrix T
!> warrants expensive computations which guarantee high relative accuracy
!> in the eigenvalues.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension (N) !> The N diagonal elements of the tridiagonal matrix T. !>
[in,out]	E	!> E is DOUBLE PRECISION array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) is set to ZERO. !>
[out]	INFO	!> INFO is INTEGER !> INFO = 0(default) : the matrix warrants computations preserving !> relative accuracy. !> INFO = 1 : the matrix warrants computations guaranteeing !> only absolute accuracy. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 93 of file dlarrr.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N, INFO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * )
*     ..
*
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, RELCOND
      parameter( zero = 0.0d0,
     $                     relcond = 0.999d0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      LOGICAL            YESREL
      DOUBLE PRECISION   EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
     $          OFFDIG, OFFDIG2
 
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         info = 0
         RETURN
      END IF
*
*     As a default, do NOT go for relative-accuracy preserving computations.
      info = 1
 
      safmin = dlamch( 'Safe minimum' )
      eps = dlamch( 'Precision' )
      smlnum = safmin / eps
      rmin = sqrt( smlnum )
 
*     Tests for relative accuracy
*
*     Test for scaled diagonal dominance
*     Scale the diagonal entries to one and check whether the sum of the
*     off-diagonals is less than one
*
*     The sdd relative error bounds have a 1/(1- 2*x) factor in them,
*     x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
*     accuracy is promised.  In the notation of the code fragment below,
*     1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
*     We don't think it is worth going into "sdd mode" unless the relative
*     condition number is reasonable, not 1/macheps.
*     The threshold should be compatible with other thresholds used in the
*     code. We set  OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
*     to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
*     instead of the current OFFDIG + OFFDIG2 < 1
*
      yesrel = .true.
      offdig = zero
      tmp = sqrt(abs(d(1)))
      IF (tmp.LT.rmin) yesrel = .false.
      IF(.NOT.yesrel) GOTO 11
      DO 10 i = 2, n
         tmp2 = sqrt(abs(d(i)))
         IF (tmp2.LT.rmin) yesrel = .false.
         IF(.NOT.yesrel) GOTO 11
         offdig2 = abs(e(i-1))/(tmp*tmp2)
         IF(offdig+offdig2.GE.relcond) yesrel = .false.
         IF(.NOT.yesrel) GOTO 11
         tmp = tmp2
         offdig = offdig2
 10   CONTINUE
 11   CONTINUE
 
      IF( yesrel ) THEN
         info = 0
         RETURN
      ELSE
      ENDIF
*
 
*
*     *** MORE TO BE IMPLEMENTED ***
*
 
*
*     Test if the lower bidiagonal matrix L from T = L D L^T
*     (zero shift facto) is well conditioned
*
 
*
*     Test if the upper bidiagonal matrix U from T = U D U^T
*     (zero shift facto) is well conditioned.
*     In this case, the matrix needs to be flipped and, at the end
*     of the eigenvector computation, the flip needs to be applied
*     to the computed eigenvectors (and the support)
*
 
*
      RETURN
*
*     End of DLARRR
*

dlartg()

subroutine dlartg	(	real(wp)	f,
		real(wp)	g,
		real(wp)	c,
		real(wp)	s,
		real(wp)	r )

DLARTG generates a plane rotation with real cosine and real sine.

Purpose:

!>
!> DLARTG generates a plane rotation so that
!>
!>    [  C  S  ]  .  [ F ]  =  [ R ]
!>    [ -S  C  ]     [ G ]     [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>    R = sign(F) * sqrt(F**2 + G**2)
!>    C = F / R
!>    S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as ZLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine DROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!>       floating point operations (saves work in DBDSQR when
!>       there are zeros on the diagonal).
!>
!> If F exceeds G in magnitude, C will be positive.
!>
!> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
!> 

Parameters

[in]	F	!> F is REAL(wp) !> The first component of vector to be rotated. !>
[in]	G	!> G is REAL(wp) !> The second component of vector to be rotated. !>
[out]	C	!> C is REAL(wp) !> The cosine of the rotation. !>
[out]	S	!> S is REAL(wp) !> The sine of the rotation. !>
[out]	R	!> R is REAL(wp) !> The nonzero component of the rotated vector. !>

Author

Edward Anderson, Lockheed Martin

Date

July 2016

Contributors:

Weslley Pereira, University of Colorado Denver, USA

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> 

Definition at line 112 of file dlartg.f90.

   use la_constants, &
   only: wp=>dp, zero=>dzero, half=>dhalf, one=>done, &
         rtmin=>drtmin, rtmax=>drtmax, safmin=>dsafmin, safmax=>dsafmax
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp) :: c, f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, fs, g1, gs, p, u, uu
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, sign, sqrt
!  ..
!  .. Executable Statements ..
!
   f1 = abs( f )
   g1 = abs( g )
   if( g == zero ) then
      c = one
      s = zero
      r = f
   else if( f == zero ) then
      c = zero
      s = sign( one, g )
      r = g1
   else if( f1 > rtmin .and. f1 < rtmax .and. &
            g1 > rtmin .and. g1 < rtmax ) then
      d = sqrt( f*f + g*g )
      p = one / d
      c = f1*p
      s = g*sign( p, f )
      r = sign( d, f )
   else
      u = min( safmax, max( safmin, f1, g1 ) )
      uu = one / u
      fs = f*uu
      gs = g*uu
      d = sqrt( fs*fs + gs*gs )
      p = one / d
      c = abs( fs )*p
      s = gs*sign( p, f )
      r = sign( d, f )*u
   end if
   return

dlartgp()

subroutine dlartgp	(	double precision	f,
		double precision	g,
		double precision	cs,
		double precision	sn,
		double precision	r )

DLARTGP generates a plane rotation so that the diagonal is nonnegative.

Download DLARTGP + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARTGP generates a plane rotation so that
!>
!>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
!>    [ -SN  CS  ]     [ G ]     [ 0 ]
!>
!> This is a slower, more accurate version of the Level 1 BLAS routine DROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then CS=(+/-)1 and SN=0.
!>    If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.
!>
!> The sign is chosen so that R >= 0.
!> 

Parameters

[in]	F	!> F is DOUBLE PRECISION !> The first component of vector to be rotated. !>
[in]	G	!> G is DOUBLE PRECISION !> The second component of vector to be rotated. !>
[out]	CS	!> CS is DOUBLE PRECISION !> The cosine of the rotation. !>
[out]	SN	!> SN is DOUBLE PRECISION !> The sine of the rotation. !>
[out]	R	!> R is DOUBLE PRECISION !> The nonzero component of the rotated vector. !> !> This version has a few statements commented out for thread safety !> (machine parameters are computed on each entry). 10 feb 03, SJH. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 94 of file dlartgp.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CS, F, G, R, SN
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
*     ..
*     .. Local Scalars ..
*     LOGICAL            FIRST
      INTEGER            COUNT, I
      DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max, sign, sqrt
*     ..
*     .. Save statement ..
*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
*     ..
*     .. Data statements ..
*     DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
*     IF( FIRST ) THEN
         safmin = dlamch( 'S' )
         eps = dlamch( 'E' )
         safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
     $            log( dlamch( 'B' ) ) / two )
         safmx2 = one / safmn2
*        FIRST = .FALSE.
*     END IF
      IF( g.EQ.zero ) THEN
         cs = sign( one, f )
         sn = zero
         r = abs( f )
      ELSE IF( f.EQ.zero ) THEN
         cs = zero
         sn = sign( one, g )
         r = abs( g )
      ELSE
         f1 = f
         g1 = g
         scale = max( abs( f1 ), abs( g1 ) )
         IF( scale.GE.safmx2 ) THEN
            count = 0
   10       CONTINUE
            count = count + 1
            f1 = f1*safmn2
            g1 = g1*safmn2
            scale = max( abs( f1 ), abs( g1 ) )
            IF( scale.GE.safmx2 .AND. count .LT. 20 )
     $         GO TO 10
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
            DO 20 i = 1, count
               r = r*safmx2
   20       CONTINUE
         ELSE IF( scale.LE.safmn2 ) THEN
            count = 0
   30       CONTINUE
            count = count + 1
            f1 = f1*safmx2
            g1 = g1*safmx2
            scale = max( abs( f1 ), abs( g1 ) )
            IF( scale.LE.safmn2 )
     $         GO TO 30
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
            DO 40 i = 1, count
               r = r*safmn2
   40       CONTINUE
         ELSE
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
         END IF
         IF( r.LT.zero ) THEN
            cs = -cs
            sn = -sn
            r = -r
         END IF
      END IF
      RETURN
*
*     End of DLARTGP
*

dlaruv()

subroutine dlaruv	(	integer, dimension( 4 )	iseed,
		integer	n,
		double precision, dimension( n )	x )

DLARUV returns a vector of n random real numbers from a uniform distribution.

Download DLARUV + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARUV returns a vector of n random real numbers from a uniform (0,1)
!> distribution (n <= 128).
!>
!> This is an auxiliary routine called by DLARNV and ZLARNV.
!> 

Parameters

[in,out]	ISEED	!> ISEED is INTEGER array, dimension (4) !> On entry, the seed of the random number generator; the array !> elements must be between 0 and 4095, and ISEED(4) must be !> odd. !> On exit, the seed is updated. !>
[in]	N	!> N is INTEGER !> The number of random numbers to be generated. N <= 128. !>
[out]	X	!> X is DOUBLE PRECISION array, dimension (N) !> The generated random numbers. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  This routine uses a multiplicative congruential method with modulus
!>  2**48 and multiplier 33952834046453 (see G.S.Fishman,
!>  'Multiplicative congruential random number generators with modulus
!>  2**b: an exhaustive analysis for b = 32 and a partial analysis for
!>  b = 48', Math. Comp. 189, pp 331-344, 1990).
!>
!>  48-bit integers are stored in 4 integer array elements with 12 bits
!>  per element. Hence the routine is portable across machines with
!>  integers of 32 bits or more.
!> 

Definition at line 94 of file dlaruv.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   X( N )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      INTEGER            LV, IPW2
      DOUBLE PRECISION   R
      parameter( lv = 128, ipw2 = 4096, r = one / ipw2 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
*     ..
*     .. Local Arrays ..
      INTEGER            MM( LV, 4 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dble, min, mod
*     ..
*     .. Data statements ..
      DATA               ( mm( 1, j ), j = 1, 4 ) / 494, 322, 2508,
     $                   2549 /
      DATA               ( mm( 2, j ), j = 1, 4 ) / 2637, 789, 3754,
     $                   1145 /
      DATA               ( mm( 3, j ), j = 1, 4 ) / 255, 1440, 1766,
     $                   2253 /
      DATA               ( mm( 4, j ), j = 1, 4 ) / 2008, 752, 3572,
     $                   305 /
      DATA               ( mm( 5, j ), j = 1, 4 ) / 1253, 2859, 2893,
     $                   3301 /
      DATA               ( mm( 6, j ), j = 1, 4 ) / 3344, 123, 307,
     $                   1065 /
      DATA               ( mm( 7, j ), j = 1, 4 ) / 4084, 1848, 1297,
     $                   3133 /
      DATA               ( mm( 8, j ), j = 1, 4 ) / 1739, 643, 3966,
     $                   2913 /
      DATA               ( mm( 9, j ), j = 1, 4 ) / 3143, 2405, 758,
     $                   3285 /
      DATA               ( mm( 10, j ), j = 1, 4 ) / 3468, 2638, 2598,
     $                   1241 /
      DATA               ( mm( 11, j ), j = 1, 4 ) / 688, 2344, 3406,
     $                   1197 /
      DATA               ( mm( 12, j ), j = 1, 4 ) / 1657, 46, 2922,
     $                   3729 /
      DATA               ( mm( 13, j ), j = 1, 4 ) / 1238, 3814, 1038,
     $                   2501 /
      DATA               ( mm( 14, j ), j = 1, 4 ) / 3166, 913, 2934,
     $                   1673 /
      DATA               ( mm( 15, j ), j = 1, 4 ) / 1292, 3649, 2091,
     $                   541 /
      DATA               ( mm( 16, j ), j = 1, 4 ) / 3422, 339, 2451,
     $                   2753 /
      DATA               ( mm( 17, j ), j = 1, 4 ) / 1270, 3808, 1580,
     $                   949 /
      DATA               ( mm( 18, j ), j = 1, 4 ) / 2016, 822, 1958,
     $                   2361 /
      DATA               ( mm( 19, j ), j = 1, 4 ) / 154, 2832, 2055,
     $                   1165 /
      DATA               ( mm( 20, j ), j = 1, 4 ) / 2862, 3078, 1507,
     $                   4081 /
      DATA               ( mm( 21, j ), j = 1, 4 ) / 697, 3633, 1078,
     $                   2725 /
      DATA               ( mm( 22, j ), j = 1, 4 ) / 1706, 2970, 3273,
     $                   3305 /
      DATA               ( mm( 23, j ), j = 1, 4 ) / 491, 637, 17,
     $                   3069 /
      DATA               ( mm( 24, j ), j = 1, 4 ) / 931, 2249, 854,
     $                   3617 /
      DATA               ( mm( 25, j ), j = 1, 4 ) / 1444, 2081, 2916,
     $                   3733 /
      DATA               ( mm( 26, j ), j = 1, 4 ) / 444, 4019, 3971,
     $                   409 /
      DATA               ( mm( 27, j ), j = 1, 4 ) / 3577, 1478, 2889,
     $                   2157 /
      DATA               ( mm( 28, j ), j = 1, 4 ) / 3944, 242, 3831,
     $                   1361 /
      DATA               ( mm( 29, j ), j = 1, 4 ) / 2184, 481, 2621,
     $                   3973 /
      DATA               ( mm( 30, j ), j = 1, 4 ) / 1661, 2075, 1541,
     $                   1865 /
      DATA               ( mm( 31, j ), j = 1, 4 ) / 3482, 4058, 893,
     $                   2525 /
      DATA               ( mm( 32, j ), j = 1, 4 ) / 657, 622, 736,
     $                   1409 /
      DATA               ( mm( 33, j ), j = 1, 4 ) / 3023, 3376, 3992,
     $                   3445 /
      DATA               ( mm( 34, j ), j = 1, 4 ) / 3618, 812, 787,
     $                   3577 /
      DATA               ( mm( 35, j ), j = 1, 4 ) / 1267, 234, 2125,
     $                   77 /
      DATA               ( mm( 36, j ), j = 1, 4 ) / 1828, 641, 2364,
     $                   3761 /
      DATA               ( mm( 37, j ), j = 1, 4 ) / 164, 4005, 2460,
     $                   2149 /
      DATA               ( mm( 38, j ), j = 1, 4 ) / 3798, 1122, 257,
     $                   1449 /
      DATA               ( mm( 39, j ), j = 1, 4 ) / 3087, 3135, 1574,
     $                   3005 /
      DATA               ( mm( 40, j ), j = 1, 4 ) / 2400, 2640, 3912,
     $                   225 /
      DATA               ( mm( 41, j ), j = 1, 4 ) / 2870, 2302, 1216,
     $                   85 /
      DATA               ( mm( 42, j ), j = 1, 4 ) / 3876, 40, 3248,
     $                   3673 /
      DATA               ( mm( 43, j ), j = 1, 4 ) / 1905, 1832, 3401,
     $                   3117 /
      DATA               ( mm( 44, j ), j = 1, 4 ) / 1593, 2247, 2124,
     $                   3089 /
      DATA               ( mm( 45, j ), j = 1, 4 ) / 1797, 2034, 2762,
     $                   1349 /
      DATA               ( mm( 46, j ), j = 1, 4 ) / 1234, 2637, 149,
     $                   2057 /
      DATA               ( mm( 47, j ), j = 1, 4 ) / 3460, 1287, 2245,
     $                   413 /
      DATA               ( mm( 48, j ), j = 1, 4 ) / 328, 1691, 166,
     $                   65 /
      DATA               ( mm( 49, j ), j = 1, 4 ) / 2861, 496, 466,
     $                   1845 /
      DATA               ( mm( 50, j ), j = 1, 4 ) / 1950, 1597, 4018,
     $                   697 /
      DATA               ( mm( 51, j ), j = 1, 4 ) / 617, 2394, 1399,
     $                   3085 /
      DATA               ( mm( 52, j ), j = 1, 4 ) / 2070, 2584, 190,
     $                   3441 /
      DATA               ( mm( 53, j ), j = 1, 4 ) / 3331, 1843, 2879,
     $                   1573 /
      DATA               ( mm( 54, j ), j = 1, 4 ) / 769, 336, 153,
     $                   3689 /
      DATA               ( mm( 55, j ), j = 1, 4 ) / 1558, 1472, 2320,
     $                   2941 /
      DATA               ( mm( 56, j ), j = 1, 4 ) / 2412, 2407, 18,
     $                   929 /
      DATA               ( mm( 57, j ), j = 1, 4 ) / 2800, 433, 712,
     $                   533 /
      DATA               ( mm( 58, j ), j = 1, 4 ) / 189, 2096, 2159,
     $                   2841 /
      DATA               ( mm( 59, j ), j = 1, 4 ) / 287, 1761, 2318,
     $                   4077 /
      DATA               ( mm( 60, j ), j = 1, 4 ) / 2045, 2810, 2091,
     $                   721 /
      DATA               ( mm( 61, j ), j = 1, 4 ) / 1227, 566, 3443,
     $                   2821 /
      DATA               ( mm( 62, j ), j = 1, 4 ) / 2838, 442, 1510,
     $                   2249 /
      DATA               ( mm( 63, j ), j = 1, 4 ) / 209, 41, 449,
     $                   2397 /
      DATA               ( mm( 64, j ), j = 1, 4 ) / 2770, 1238, 1956,
     $                   2817 /
      DATA               ( mm( 65, j ), j = 1, 4 ) / 3654, 1086, 2201,
     $                   245 /
      DATA               ( mm( 66, j ), j = 1, 4 ) / 3993, 603, 3137,
     $                   1913 /
      DATA               ( mm( 67, j ), j = 1, 4 ) / 192, 840, 3399,
     $                   1997 /
      DATA               ( mm( 68, j ), j = 1, 4 ) / 2253, 3168, 1321,
     $                   3121 /
      DATA               ( mm( 69, j ), j = 1, 4 ) / 3491, 1499, 2271,
     $                   997 /
      DATA               ( mm( 70, j ), j = 1, 4 ) / 2889, 1084, 3667,
     $                   1833 /
      DATA               ( mm( 71, j ), j = 1, 4 ) / 2857, 3438, 2703,
     $                   2877 /
      DATA               ( mm( 72, j ), j = 1, 4 ) / 2094, 2408, 629,
     $                   1633 /
      DATA               ( mm( 73, j ), j = 1, 4 ) / 1818, 1589, 2365,
     $                   981 /
      DATA               ( mm( 74, j ), j = 1, 4 ) / 688, 2391, 2431,
     $                   2009 /
      DATA               ( mm( 75, j ), j = 1, 4 ) / 1407, 288, 1113,
     $                   941 /
      DATA               ( mm( 76, j ), j = 1, 4 ) / 634, 26, 3922,
     $                   2449 /
      DATA               ( mm( 77, j ), j = 1, 4 ) / 3231, 512, 2554,
     $                   197 /
      DATA               ( mm( 78, j ), j = 1, 4 ) / 815, 1456, 184,
     $                   2441 /
      DATA               ( mm( 79, j ), j = 1, 4 ) / 3524, 171, 2099,
     $                   285 /
      DATA               ( mm( 80, j ), j = 1, 4 ) / 1914, 1677, 3228,
     $                   1473 /
      DATA               ( mm( 81, j ), j = 1, 4 ) / 516, 2657, 4012,
     $                   2741 /
      DATA               ( mm( 82, j ), j = 1, 4 ) / 164, 2270, 1921,
     $                   3129 /
      DATA               ( mm( 83, j ), j = 1, 4 ) / 303, 2587, 3452,
     $                   909 /
      DATA               ( mm( 84, j ), j = 1, 4 ) / 2144, 2961, 3901,
     $                   2801 /
      DATA               ( mm( 85, j ), j = 1, 4 ) / 3480, 1970, 572,
     $                   421 /
      DATA               ( mm( 86, j ), j = 1, 4 ) / 119, 1817, 3309,
     $                   4073 /
      DATA               ( mm( 87, j ), j = 1, 4 ) / 3357, 676, 3171,
     $                   2813 /
      DATA               ( mm( 88, j ), j = 1, 4 ) / 837, 1410, 817,
     $                   2337 /
      DATA               ( mm( 89, j ), j = 1, 4 ) / 2826, 3723, 3039,
     $                   1429 /
      DATA               ( mm( 90, j ), j = 1, 4 ) / 2332, 2803, 1696,
     $                   1177 /
      DATA               ( mm( 91, j ), j = 1, 4 ) / 2089, 3185, 1256,
     $                   1901 /
      DATA               ( mm( 92, j ), j = 1, 4 ) / 3780, 184, 3715,
     $                   81 /
      DATA               ( mm( 93, j ), j = 1, 4 ) / 1700, 663, 2077,
     $                   1669 /
      DATA               ( mm( 94, j ), j = 1, 4 ) / 3712, 499, 3019,
     $                   2633 /
      DATA               ( mm( 95, j ), j = 1, 4 ) / 150, 3784, 1497,
     $                   2269 /
      DATA               ( mm( 96, j ), j = 1, 4 ) / 2000, 1631, 1101,
     $                   129 /
      DATA               ( mm( 97, j ), j = 1, 4 ) / 3375, 1925, 717,
     $                   1141 /
      DATA               ( mm( 98, j ), j = 1, 4 ) / 1621, 3912, 51,
     $                   249 /
      DATA               ( mm( 99, j ), j = 1, 4 ) / 3090, 1398, 981,
     $                   3917 /
      DATA               ( mm( 100, j ), j = 1, 4 ) / 3765, 1349, 1978,
     $                   2481 /
      DATA               ( mm( 101, j ), j = 1, 4 ) / 1149, 1441, 1813,
     $                   3941 /
      DATA               ( mm( 102, j ), j = 1, 4 ) / 3146, 2224, 3881,
     $                   2217 /
      DATA               ( mm( 103, j ), j = 1, 4 ) / 33, 2411, 76,
     $                   2749 /
      DATA               ( mm( 104, j ), j = 1, 4 ) / 3082, 1907, 3846,
     $                   3041 /
      DATA               ( mm( 105, j ), j = 1, 4 ) / 2741, 3192, 3694,
     $                   1877 /
      DATA               ( mm( 106, j ), j = 1, 4 ) / 359, 2786, 1682,
     $                   345 /
      DATA               ( mm( 107, j ), j = 1, 4 ) / 3316, 382, 124,
     $                   2861 /
      DATA               ( mm( 108, j ), j = 1, 4 ) / 1749, 37, 1660,
     $                   1809 /
      DATA               ( mm( 109, j ), j = 1, 4 ) / 185, 759, 3997,
     $                   3141 /
      DATA               ( mm( 110, j ), j = 1, 4 ) / 2784, 2948, 479,
     $                   2825 /
      DATA               ( mm( 111, j ), j = 1, 4 ) / 2202, 1862, 1141,
     $                   157 /
      DATA               ( mm( 112, j ), j = 1, 4 ) / 2199, 3802, 886,
     $                   2881 /
      DATA               ( mm( 113, j ), j = 1, 4 ) / 1364, 2423, 3514,
     $                   3637 /
      DATA               ( mm( 114, j ), j = 1, 4 ) / 1244, 2051, 1301,
     $                   1465 /
      DATA               ( mm( 115, j ), j = 1, 4 ) / 2020, 2295, 3604,
     $                   2829 /
      DATA               ( mm( 116, j ), j = 1, 4 ) / 3160, 1332, 1888,
     $                   2161 /
      DATA               ( mm( 117, j ), j = 1, 4 ) / 2785, 1832, 1836,
     $                   3365 /
      DATA               ( mm( 118, j ), j = 1, 4 ) / 2772, 2405, 1990,
     $                   361 /
      DATA               ( mm( 119, j ), j = 1, 4 ) / 1217, 3638, 2058,
     $                   2685 /
      DATA               ( mm( 120, j ), j = 1, 4 ) / 1822, 3661, 692,
     $                   3745 /
      DATA               ( mm( 121, j ), j = 1, 4 ) / 1245, 327, 1194,
     $                   2325 /
      DATA               ( mm( 122, j ), j = 1, 4 ) / 2252, 3660, 20,
     $                   3609 /
      DATA               ( mm( 123, j ), j = 1, 4 ) / 3904, 716, 3285,
     $                   3821 /
      DATA               ( mm( 124, j ), j = 1, 4 ) / 2774, 1842, 2046,
     $                   3537 /
      DATA               ( mm( 125, j ), j = 1, 4 ) / 997, 3987, 2107,
     $                   517 /
      DATA               ( mm( 126, j ), j = 1, 4 ) / 2573, 1368, 3508,
     $                   3017 /
      DATA               ( mm( 127, j ), j = 1, 4 ) / 1148, 1848, 3525,
     $                   2141 /
      DATA               ( mm( 128, j ), j = 1, 4 ) / 545, 2366, 3801,
     $                   1537 /
*     ..
*     .. Executable Statements ..
*
      i1 = iseed( 1 )
      i2 = iseed( 2 )
      i3 = iseed( 3 )
      i4 = iseed( 4 )
*
      DO 10 i = 1, min( n, lv )
*
  20     CONTINUE
*
*        Multiply the seed by i-th power of the multiplier modulo 2**48
*
         it4 = i4*mm( i, 4 )
         it3 = it4 / ipw2
         it4 = it4 - ipw2*it3
         it3 = it3 + i3*mm( i, 4 ) + i4*mm( i, 3 )
         it2 = it3 / ipw2
         it3 = it3 - ipw2*it2
         it2 = it2 + i2*mm( i, 4 ) + i3*mm( i, 3 ) + i4*mm( i, 2 )
         it1 = it2 / ipw2
         it2 = it2 - ipw2*it1
         it1 = it1 + i1*mm( i, 4 ) + i2*mm( i, 3 ) + i3*mm( i, 2 ) +
     $         i4*mm( i, 1 )
         it1 = mod( it1, ipw2 )
*
*        Convert 48-bit integer to a real number in the interval (0,1)
*
         x( i ) = r*( dble( it1 )+r*( dble( it2 )+r*( dble( it3 )+r*
     $            dble( it4 ) ) ) )
*
         IF (x( i ).EQ.1.0d0) THEN
*           If a real number has n bits of precision, and the first
*           n bits of the 48-bit integer above happen to be all 1 (which
*           will occur about once every 2**n calls), then X( I ) will
*           be rounded to exactly 1.0.
*           Since X( I ) is not supposed to return exactly 0.0 or 1.0,
*           the statistically correct thing to do in this situation is
*           simply to iterate again.
*           N.B. the case X( I ) = 0.0 should not be possible.
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            i4 = i4 + 2
            GOTO 20
         END IF
*
   10 CONTINUE
*
*     Return final value of seed
*
      iseed( 1 ) = it1
      iseed( 2 ) = it2
      iseed( 3 ) = it3
      iseed( 4 ) = it4
      RETURN
*
*     End of DLARUV
*

dlas2()

subroutine dlas2	(	double precision	f,
		double precision	g,
		double precision	h,
		double precision	ssmin,
		double precision	ssmax )

DLAS2 computes singular values of a 2-by-2 triangular matrix.

Download DLAS2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLAS2  computes the singular values of the 2-by-2 matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, SSMIN is the smaller singular value and SSMAX is the
!> larger singular value.
!> 

Parameters

[in]	F	!> F is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !>
[in]	G	!> G is DOUBLE PRECISION !> The (1,2) element of the 2-by-2 matrix. !>
[in]	H	!> H is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !>
[out]	SSMIN	!> SSMIN is DOUBLE PRECISION !> The smaller singular value. !>
[out]	SSMAX	!> SSMAX is DOUBLE PRECISION !> The larger singular value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  Barring over/underflow, all output quantities are correct to within
!>  a few units in the last place (ulps), even in the absence of a guard
!>  digit in addition/subtraction.
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows, or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> 

Definition at line 106 of file dlas2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   F, G, H, SSMAX, SSMIN
*     ..
*
*  ====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. Executable Statements ..
*
      fa = abs( f )
      ga = abs( g )
      ha = abs( h )
      fhmn = min( fa, ha )
      fhmx = max( fa, ha )
      IF( fhmn.EQ.zero ) THEN
         ssmin = zero
         IF( fhmx.EQ.zero ) THEN
            ssmax = ga
         ELSE
            ssmax = max( fhmx, ga )*sqrt( one+
     $              ( min( fhmx, ga ) / max( fhmx, ga ) )**2 )
         END IF
      ELSE
         IF( ga.LT.fhmx ) THEN
            as = one + fhmn / fhmx
            at = ( fhmx-fhmn ) / fhmx
            au = ( ga / fhmx )**2
            c = two / ( sqrt( as*as+au )+sqrt( at*at+au ) )
            ssmin = fhmn*c
            ssmax = fhmx / c
         ELSE
            au = fhmx / ga
            IF( au.EQ.zero ) THEN
*
*              Avoid possible harmful underflow if exponent range
*              asymmetric (true SSMIN may not underflow even if
*              AU underflows)
*
               ssmin = ( fhmn*fhmx ) / ga
               ssmax = ga
            ELSE
               as = one + fhmn / fhmx
               at = ( fhmx-fhmn ) / fhmx
               c = one / ( sqrt( one+( as*au )**2 )+
     $             sqrt( one+( at*au )**2 ) )
               ssmin = ( fhmn*c )*au
               ssmin = ssmin + ssmin
               ssmax = ga / ( c+c )
            END IF
         END IF
      END IF
      RETURN
*
*     End of DLAS2
*

dlascl()

subroutine dlascl	(	character	type,
		integer	kl,
		integer	ku,
		double precision	cfrom,
		double precision	cto,
		integer	m,
		integer	n,
		double precision, dimension( lda, * )	a,
		integer	lda,
		integer	info )

DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.

Download DLASCL + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASCL multiplies the M by N real matrix A by the real scalar
!> CTO/CFROM.  This is done without over/underflow as long as the final
!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!> A may be full, upper triangular, lower triangular, upper Hessenberg,
!> or banded.
!> 

Parameters

[in]	TYPE	!> TYPE is CHARACTER*1 !> TYPE indices the storage type of the input matrix. !> = 'G': A is a full matrix. !> = 'L': A is a lower triangular matrix. !> = 'U': A is an upper triangular matrix. !> = 'H': A is an upper Hessenberg matrix. !> = 'B': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the lower !> half stored. !> = 'Q': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the upper !> half stored. !> = 'Z': A is a band matrix with lower bandwidth KL and upper !> bandwidth KU. See DGBTRF for storage details. !>
[in]	KL	!> KL is INTEGER !> The lower bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !>
[in]	KU	!> KU is INTEGER !> The upper bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !>
[in]	CFROM	!> CFROM is DOUBLE PRECISION !>
[in]	CTO	!> CTO is DOUBLE PRECISION !> !> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed !> without over/underflow if the final result CTO*A(I,J)/CFROM !> can be represented without over/underflow. CFROM must be !> nonzero. !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in,out]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> The matrix to be multiplied by CTO/CFROM. See TYPE for the !> storage type. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. !> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); !> TYPE = 'B', LDA >= KL+1; !> TYPE = 'Q', LDA >= KU+1; !> TYPE = 'Z', LDA >= 2*KL+KU+1. !>
[out]	INFO	!> INFO is INTEGER !> 0 - successful exit !> <0 - if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 142 of file dlascl.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      DOUBLE PRECISION   CFROM, CTO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d0, one = 1.0d0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, DISNAN
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           lsame, dlamch, disnan
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      info = 0
*
      IF( lsame( TYPE, 'G' ) ) THEN
         itype = 0
      ELSE IF( lsame( TYPE, 'L' ) ) THEN
         itype = 1
      ELSE IF( lsame( TYPE, 'U' ) ) THEN
         itype = 2
      ELSE IF( lsame( TYPE, 'H' ) ) THEN
         itype = 3
      ELSE IF( lsame( TYPE, 'B' ) ) THEN
         itype = 4
      ELSE IF( lsame( TYPE, 'Q' ) ) THEN
         itype = 5
      ELSE IF( lsame( TYPE, 'Z' ) ) THEN
         itype = 6
      ELSE
         itype = -1
      END IF
*
      IF( itype.EQ.-1 ) THEN
         info = -1
      ELSE IF( cfrom.EQ.zero .OR. disnan(cfrom) ) THEN
         info = -4
      ELSE IF( disnan(cto) ) THEN
         info = -5
      ELSE IF( m.LT.0 ) THEN
         info = -6
      ELSE IF( n.LT.0 .OR. ( itype.EQ.4 .AND. n.NE.m ) .OR.
     $         ( itype.EQ.5 .AND. n.NE.m ) ) THEN
         info = -7
      ELSE IF( itype.LE.3 .AND. lda.LT.max( 1, m ) ) THEN
         info = -9
      ELSE IF( itype.GE.4 ) THEN
         IF( kl.LT.0 .OR. kl.GT.max( m-1, 0 ) ) THEN
            info = -2
         ELSE IF( ku.LT.0 .OR. ku.GT.max( n-1, 0 ) .OR.
     $            ( ( itype.EQ.4 .OR. itype.EQ.5 ) .AND. kl.NE.ku ) )
     $             THEN
            info = -3
         ELSE IF( ( itype.EQ.4 .AND. lda.LT.kl+1 ) .OR.
     $            ( itype.EQ.5 .AND. lda.LT.ku+1 ) .OR.
     $            ( itype.EQ.6 .AND. lda.LT.2*kl+ku+1 ) ) THEN
            info = -9
         END IF
      END IF
*
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASCL', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.EQ.0 .OR. m.EQ.0 )
     $   RETURN
*
*     Get machine parameters
*
      smlnum = dlamch( 'S' )
      bignum = one / smlnum
*
      cfromc = cfrom
      ctoc = cto
*
   10 CONTINUE
      cfrom1 = cfromc*smlnum
      IF( cfrom1.EQ.cfromc ) THEN
!        CFROMC is an inf.  Multiply by a correctly signed zero for
!        finite CTOC, or a NaN if CTOC is infinite.
         mul = ctoc / cfromc
         done = .true.
         cto1 = ctoc
      ELSE
         cto1 = ctoc / bignum
         IF( cto1.EQ.ctoc ) THEN
!           CTOC is either 0 or an inf.  In both cases, CTOC itself
!           serves as the correct multiplication factor.
            mul = ctoc
            done = .true.
            cfromc = one
         ELSE IF( abs( cfrom1 ).GT.abs( ctoc ) .AND. ctoc.NE.zero ) THEN
            mul = smlnum
            done = .false.
            cfromc = cfrom1
         ELSE IF( abs( cto1 ).GT.abs( cfromc ) ) THEN
            mul = bignum
            done = .false.
            ctoc = cto1
         ELSE
            mul = ctoc / cfromc
            done = .true.
         END IF
      END IF
*
      IF( itype.EQ.0 ) THEN
*
*        Full matrix
*
         DO 30 j = 1, n
            DO 20 i = 1, m
               a( i, j ) = a( i, j )*mul
   20       CONTINUE
   30    CONTINUE
*
      ELSE IF( itype.EQ.1 ) THEN
*
*        Lower triangular matrix
*
         DO 50 j = 1, n
            DO 40 i = j, m
               a( i, j ) = a( i, j )*mul
   40       CONTINUE
   50    CONTINUE
*
      ELSE IF( itype.EQ.2 ) THEN
*
*        Upper triangular matrix
*
         DO 70 j = 1, n
            DO 60 i = 1, min( j, m )
               a( i, j ) = a( i, j )*mul
   60       CONTINUE
   70    CONTINUE
*
      ELSE IF( itype.EQ.3 ) THEN
*
*        Upper Hessenberg matrix
*
         DO 90 j = 1, n
            DO 80 i = 1, min( j+1, m )
               a( i, j ) = a( i, j )*mul
   80       CONTINUE
   90    CONTINUE
*
      ELSE IF( itype.EQ.4 ) THEN
*
*        Lower half of a symmetric band matrix
*
         k3 = kl + 1
         k4 = n + 1
         DO 110 j = 1, n
            DO 100 i = 1, min( k3, k4-j )
               a( i, j ) = a( i, j )*mul
  100       CONTINUE
  110    CONTINUE
*
      ELSE IF( itype.EQ.5 ) THEN
*
*        Upper half of a symmetric band matrix
*
         k1 = ku + 2
         k3 = ku + 1
         DO 130 j = 1, n
            DO 120 i = max( k1-j, 1 ), k3
               a( i, j ) = a( i, j )*mul
  120       CONTINUE
  130    CONTINUE
*
      ELSE IF( itype.EQ.6 ) THEN
*
*        Band matrix
*
         k1 = kl + ku + 2
         k2 = kl + 1
         k3 = 2*kl + ku + 1
         k4 = kl + ku + 1 + m
         DO 150 j = 1, n
            DO 140 i = max( k1-j, k2 ), min( k3, k4-j )
               a( i, j ) = a( i, j )*mul
  140       CONTINUE
  150    CONTINUE
*
      END IF
*
      IF( .NOT.done )
     $   GO TO 10
*
      RETURN
*
*     End of DLASCL
*

dlasd0()

subroutine dlasd0	(	integer	n,
		integer	sqre,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldvt, * )	vt,
		integer	ldvt,
		integer	smlsiz,
		integer, dimension( * )	iwork,
		double precision, dimension( * )	work,
		integer	info )

DLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc.

Download DLASD0 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Using a divide and conquer approach, DLASD0 computes the singular
!> value decomposition (SVD) of a real upper bidiagonal N-by-M
!> matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
!> The algorithm computes orthogonal matrices U and VT such that
!> B = U * S * VT. The singular values S are overwritten on D.
!>
!> A related subroutine, DLASDA, computes only the singular values,
!> and optionally, the singular vectors in compact form.
!> 

Parameters

[in]	N	!> N is INTEGER !> On entry, the row dimension of the upper bidiagonal matrix. !> This is also the dimension of the main diagonal array D. !>
[in]	SQRE	!> SQRE is INTEGER !> Specifies the column dimension of the bidiagonal matrix. !> = 0: The bidiagonal matrix has column dimension M = N; !> = 1: The bidiagonal matrix has column dimension M = N+1; !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension (N) !> On entry D contains the main diagonal of the bidiagonal !> matrix. !> On exit D, if INFO = 0, contains its singular values. !>
[in,out]	E	!> E is DOUBLE PRECISION array, dimension (M-1) !> Contains the subdiagonal entries of the bidiagonal matrix. !> On exit, E has been destroyed. !>
[out]	U	!> U is DOUBLE PRECISION array, dimension (LDU, N) !> On exit, U contains the left singular vectors. !>
[in]	LDU	!> LDU is INTEGER !> On entry, leading dimension of U. !>
[out]	VT	!> VT is DOUBLE PRECISION array, dimension (LDVT, M) !> On exit, VT**T contains the right singular vectors. !>
[in]	LDVT	!> LDVT is INTEGER !> On entry, leading dimension of VT. !>
[in]	SMLSIZ	!> SMLSIZ is INTEGER !> On entry, maximum size of the subproblems at the !> bottom of the computation tree. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (8*N) !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (3*M**2+2*M) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 148 of file dlasd0.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, N, SMLSIZ, SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlasd1, dlasdq, dlasdt, xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( n.LT.0 ) THEN
         info = -1
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -2
      END IF
*
      m = n + sqre
*
      IF( ldu.LT.n ) THEN
         info = -6
      ELSE IF( ldvt.LT.m ) THEN
         info = -8
      ELSE IF( smlsiz.LT.3 ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD0', -info )
         RETURN
      END IF
*
*     If the input matrix is too small, call DLASDQ to find the SVD.
*
      IF( n.LE.smlsiz ) THEN
         CALL dlasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldvt, u, ldu, u,
     $                ldu, work, info )
         RETURN
      END IF
*
*     Set up the computation tree.
*
      inode = 1
      ndiml = inode + n
      ndimr = ndiml + n
      idxq = ndimr + n
      iwk = idxq + n
      CALL dlasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
     $             iwork( ndimr ), smlsiz )
*
*     For the nodes on bottom level of the tree, solve
*     their subproblems by DLASDQ.
*
      ndb1 = ( nd+1 ) / 2
      ncc = 0
      DO 30 i = ndb1, nd
*
*     IC : center row of each node
*     NL : number of rows of left  subproblem
*     NR : number of rows of right subproblem
*     NLF: starting row of the left   subproblem
*     NRF: starting row of the right  subproblem
*
         i1 = i - 1
         ic = iwork( inode+i1 )
         nl = iwork( ndiml+i1 )
         nlp1 = nl + 1
         nr = iwork( ndimr+i1 )
         nrp1 = nr + 1
         nlf = ic - nl
         nrf = ic + 1
         sqrei = 1
         CALL dlasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ), e( nlf ),
     $                vt( nlf, nlf ), ldvt, u( nlf, nlf ), ldu,
     $                u( nlf, nlf ), ldu, work, info )
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         itemp = idxq + nlf - 2
         DO 10 j = 1, nl
            iwork( itemp+j ) = j
   10    CONTINUE
         IF( i.EQ.nd ) THEN
            sqrei = sqre
         ELSE
            sqrei = 1
         END IF
         nrp1 = nr + sqrei
         CALL dlasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ), e( nrf ),
     $                vt( nrf, nrf ), ldvt, u( nrf, nrf ), ldu,
     $                u( nrf, nrf ), ldu, work, info )
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         itemp = idxq + ic
         DO 20 j = 1, nr
            iwork( itemp+j-1 ) = j
   20    CONTINUE
   30 CONTINUE
*
*     Now conquer each subproblem bottom-up.
*
      DO 50 lvl = nlvl, 1, -1
*
*        Find the first node LF and last node LL on the
*        current level LVL.
*
         IF( lvl.EQ.1 ) THEN
            lf = 1
            ll = 1
         ELSE
            lf = 2**( lvl-1 )
            ll = 2*lf - 1
         END IF
         DO 40 i = lf, ll
            im1 = i - 1
            ic = iwork( inode+im1 )
            nl = iwork( ndiml+im1 )
            nr = iwork( ndimr+im1 )
            nlf = ic - nl
            IF( ( sqre.EQ.0 ) .AND. ( i.EQ.ll ) ) THEN
               sqrei = sqre
            ELSE
               sqrei = 1
            END IF
            idxqc = idxq + nlf - 1
            alpha = d( ic )
            beta = e( ic )
            CALL dlasd1( nl, nr, sqrei, d( nlf ), alpha, beta,
     $                   u( nlf, nlf ), ldu, vt( nlf, nlf ), ldvt,
     $                   iwork( idxqc ), iwork( iwk ), work, info )
*
*        Report the possible convergence failure.
*
            IF( info.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of DLASD0
*

dlasd1()

subroutine dlasd1	(	integer	nl,
		integer	nr,
		integer	sqre,
		double precision, dimension( * )	d,
		double precision	alpha,
		double precision	beta,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldvt, * )	vt,
		integer	ldvt,
		integer, dimension( * )	idxq,
		integer, dimension( * )	iwork,
		double precision, dimension( * )	work,
		integer	info )

DLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc.

Download DLASD1 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
!> where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
!>
!> A related subroutine DLASD7 handles the case in which the singular
!> values (and the singular vectors in factored form) are desired.
!>
!> DLASD1 computes the SVD as follows:
!>
!>               ( D1(in)    0    0       0 )
!>   B = U(in) * (   Z1**T   a   Z2**T    b ) * VT(in)
!>               (   0       0   D2(in)   0 )
!>
!>     = U(out) * ( D(out) 0) * VT(out)
!>
!> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M
!> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!> elsewhere; and the entry b is empty if SQRE = 0.
!>
!> The left singular vectors of the original matrix are stored in U, and
!> the transpose of the right singular vectors are stored in VT, and the
!> singular values are in D.  The algorithm consists of three stages:
!>
!>    The first stage consists of deflating the size of the problem
!>    when there are multiple singular values or when there are zeros 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 DLASD2.
!>
!>    The second stage consists of calculating the updated
!>    singular values. This is done by finding the square roots of the
!>    roots of the secular equation via the routine DLASD4 (as called
!>    by DLASD3). This routine also calculates the singular vectors of
!>    the current problem.
!>
!>    The final stage consists of computing the updated singular vectors
!>    directly using the updated singular values.  The singular vectors
!>    for the current problem are multiplied with the singular vectors
!>    from the overall problem.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has row dimension N = NL + NR + 1, !> and column dimension M = N + SQRE. !>
[in,out]	D	!> D is DOUBLE PRECISION array, !> dimension (N = NL+NR+1). !> On entry D(1:NL,1:NL) contains the singular values of the !> upper block; and D(NL+2:N) contains the singular values of !> the lower block. On exit D(1:N) contains the singular values !> of the modified matrix. !>
[in,out]	ALPHA	!> ALPHA is DOUBLE PRECISION !> Contains the diagonal element associated with the added row. !>
[in,out]	BETA	!> BETA is DOUBLE PRECISION !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	U	!> U is DOUBLE PRECISION array, dimension(LDU,N) !> On entry U(1:NL, 1:NL) contains the left singular vectors of !> the upper block; U(NL+2:N, NL+2:N) contains the left singular !> vectors of the lower block. On exit U contains the left !> singular vectors of the bidiagonal matrix. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= max( 1, N ). !>
[in,out]	VT	!> VT is DOUBLE PRECISION array, dimension(LDVT,M) !> where M = N + SQRE. !> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular !> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains !> the right singular vectors of the lower block. On exit !> VT**T contains the right singular vectors of the !> bidiagonal matrix. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= max( 1, M ). !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension(N) !> This contains the permutation which will reintegrate the !> subproblem just solved back into sorted order, i.e. !> D( IDXQ( I = 1, N ) ) will be in ascending order. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension( 4 * N ) !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension( 3*M**2 + 2*M ) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 202 of file dlasd1.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            IDXQ( * ), IWORK( * )
      DOUBLE PRECISION   D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
*
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
     $                   IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
      DOUBLE PRECISION   ORGNRM
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlamrg, dlascl, dlasd2, dlasd3, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -3
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD1', -info )
         RETURN
      END IF
*
      n = nl + nr + 1
      m = n + sqre
*
*     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 DLASD2 and DLASD3.
*
      ldu2 = n
      ldvt2 = m
*
      iz = 1
      isigma = iz + m
      iu2 = isigma + n
      ivt2 = iu2 + ldu2*n
      iq = ivt2 + ldvt2*m
*
      idx = 1
      idxc = idx + n
      coltyp = idxc + n
      idxp = coltyp + n
*
*     Scale.
*
      orgnrm = max( abs( alpha ), abs( beta ) )
      d( nl+1 ) = zero
      DO 10 i = 1, n
         IF( abs( d( i ) ).GT.orgnrm ) THEN
            orgnrm = abs( d( i ) )
         END IF
   10 CONTINUE
      CALL dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
      alpha = alpha / orgnrm
      beta = beta / orgnrm
*
*     Deflate singular values.
*
      CALL dlasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,
     $             vt, ldvt, work( isigma ), work( iu2 ), ldu2,
     $             work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ),
     $             iwork( idxc ), idxq, iwork( coltyp ), info )
*
*     Solve Secular Equation and update singular vectors.
*
      ldq = k
      CALL dlasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),
     $             u, ldu, work( iu2 ), ldu2, vt, ldvt, work( ivt2 ),
     $             ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ),
     $             info )
*
*     Report the convergence failure.
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
*
*     Unscale.
*
      CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
*
*     Prepare the IDXQ sorting permutation.
*
      n1 = k
      n2 = n - k
      CALL dlamrg( n1, n2, d, 1, -1, idxq )
*
      RETURN
*
*     End of DLASD1
*

dlasd2()

subroutine dlasd2	(	integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		double precision, dimension( * )	d,
		double precision, dimension( * )	z,
		double precision	alpha,
		double precision	beta,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldvt, * )	vt,
		integer	ldvt,
		double precision, dimension( * )	dsigma,
		double precision, dimension( ldu2, * )	u2,
		integer	ldu2,
		double precision, dimension( ldvt2, * )	vt2,
		integer	ldvt2,
		integer, dimension( * )	idxp,
		integer, dimension( * )	idx,
		integer, dimension( * )	idxc,
		integer, dimension( * )	idxq,
		integer, dimension( * )	coltyp,
		integer	info )

DLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc.

Download DLASD2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD2 merges the two sets of singular values 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
!> singular values 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.
!>
!> DLASD2 is called from DLASD1.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, !> This is the order of the related secular equation. 1 <= K <=N. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension(N) !> On entry D contains the singular values of the two submatrices !> to be combined. On exit D contains the trailing (N-K) updated !> singular values (those which were deflated) sorted into !> increasing order. !>
[out]	Z	!> Z is DOUBLE PRECISION array, dimension(N) !> On exit Z contains the updating row vector in the secular !> equation. !>
[in]	ALPHA	!> ALPHA is DOUBLE PRECISION !> Contains the diagonal element associated with the added row. !>
[in]	BETA	!> BETA is DOUBLE PRECISION !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	U	!> U is DOUBLE PRECISION array, dimension(LDU,N) !> On entry U contains the left singular vectors of two !> submatrices in the two square blocks with corners at (1,1), !> (NL, NL), and (NL+2, NL+2), (N,N). !> On exit U contains the trailing (N-K) updated left singular !> vectors (those which were deflated) in its last N-K columns. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= N. !>
[in,out]	VT	!> VT is DOUBLE PRECISION array, dimension(LDVT,M) !> On entry VT**T contains the right singular vectors of two !> submatrices in the two square blocks with corners at (1,1), !> (NL+1, NL+1), and (NL+2, NL+2), (M,M). !> On exit VT**T contains the trailing (N-K) updated right singular !> vectors (those which were deflated) in its last N-K columns. !> In case SQRE =1, the last row of VT spans the right null !> space. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= M. !>
[out]	DSIGMA	!> DSIGMA is DOUBLE PRECISION array, dimension (N) !> Contains a copy of the diagonal elements (K-1 singular values !> and one zero) in the secular equation. !>
[out]	U2	!> U2 is DOUBLE PRECISION array, dimension(LDU2,N) !> Contains a copy of the first K-1 left singular vectors which !> will be used by DLASD3 in a matrix multiply (DGEMM) to solve !> for the new left singular vectors. U2 is arranged into four !> blocks. The first block contains a column with 1 at NL+1 and !> zero everywhere else; the second block contains non-zero !> entries only at and above NL; the third contains non-zero !> entries only below NL+1; and the fourth is dense. !>
[in]	LDU2	!> LDU2 is INTEGER !> The leading dimension of the array U2. LDU2 >= N. !>
[out]	VT2	!> VT2 is DOUBLE PRECISION array, dimension(LDVT2,N) !> VT2**T contains a copy of the first K right singular vectors !> which will be used by DLASD3 in a matrix multiply (DGEMM) to !> solve for the new right singular vectors. VT2 is arranged into !> three blocks. The first block contains a row that corresponds !> to the special 0 diagonal element in SIGMA; the second block !> contains non-zeros only at and before NL +1; the third block !> contains non-zeros only at and after NL +2. !>
[in]	LDVT2	!> LDVT2 is INTEGER !> The leading dimension of the array VT2. LDVT2 >= M. !>
[out]	IDXP	!> IDXP is INTEGER array, dimension(N) !> This will contain the permutation used to place deflated !> values of D at the end of the array. On output IDXP(2:K) !> points to the nondeflated D-values and IDXP(K+1:N) !> points to the deflated singular values. !>
[out]	IDX	!> IDX is INTEGER array, dimension(N) !> This will contain the permutation used to sort the contents of !> D into ascending order. !>
[out]	IDXC	!> IDXC is INTEGER array, dimension(N) !> This will contain the permutation used to arrange the columns !> of the deflated U matrix into three groups: the first group !> contains non-zero entries only at and above NL, the second !> contains non-zero entries only below NL+2, and the third is !> dense. !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension(N) !> This contains the permutation which separately sorts the two !> sub-problems in D into ascending order. Note that entries in !> the first hlaf of this permutation must first be moved one !> position backward; and entries in the second half !> must first have NL+1 added to their values. !>
[out]	COLTYP	!> COLTYP is INTEGER array, dimension(N) !> As workspace, this will contain a label which will indicate !> which of the following types a column in the U2 matrix or a !> row in the VT2 matrix is: !> 1 : non-zero in the upper half only !> 2 : non-zero in the lower half only !> 3 : dense !> 4 : deflated !> !> On exit, it is an array of dimension 4, with COLTYP(I) being !> the dimension of the I-th type columns. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 266 of file dlasd2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
     $                   IDXQ( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), U( LDU, * ),
     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
      parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
     $                   eight = 8.0d+0 )
*     ..
*     .. Local Arrays ..
      INTEGER            CTOT( 4 ), PSM( 4 )
*     ..
*     .. Local Scalars ..
      INTEGER            CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
     $                   N, NLP1, NLP2
      DOUBLE PRECISION   C, EPS, HLFTOL, S, TAU, TOL, Z1
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           dlamch, dlapy2
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlacpy, dlamrg, dlaset, drot, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) ) THEN
         info = -3
      END IF
*
      n = nl + nr + 1
      m = n + sqre
*
      IF( ldu.LT.n ) THEN
         info = -10
      ELSE IF( ldvt.LT.m ) THEN
         info = -12
      ELSE IF( ldu2.LT.n ) THEN
         info = -15
      ELSE IF( ldvt2.LT.m ) THEN
         info = -17
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD2', -info )
         RETURN
      END IF
*
      nlp1 = nl + 1
      nlp2 = nl + 2
*
*     Generate the first part of the vector Z; and move the singular
*     values in the first part of D one position backward.
*
      z1 = alpha*vt( nlp1, nlp1 )
      z( 1 ) = z1
      DO 10 i = nl, 1, -1
         z( i+1 ) = alpha*vt( i, nlp1 )
         d( i+1 ) = d( i )
         idxq( i+1 ) = idxq( i ) + 1
   10 CONTINUE
*
*     Generate the second part of the vector Z.
*
      DO 20 i = nlp2, m
         z( i ) = beta*vt( i, nlp2 )
   20 CONTINUE
*
*     Initialize some reference arrays.
*
      DO 30 i = 2, nlp1
         coltyp( i ) = 1
   30 CONTINUE
      DO 40 i = nlp2, n
         coltyp( i ) = 2
   40 CONTINUE
*
*     Sort the singular values into increasing order
*
      DO 50 i = nlp2, n
         idxq( i ) = idxq( i ) + nlp1
   50 CONTINUE
*
*     DSIGMA, IDXC, IDXC, and the first column of U2
*     are used as storage space.
*
      DO 60 i = 2, n
         dsigma( i ) = d( idxq( i ) )
         u2( i, 1 ) = z( idxq( i ) )
         idxc( i ) = coltyp( idxq( i ) )
   60 CONTINUE
*
      CALL dlamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
*
      DO 70 i = 2, n
         idxi = 1 + idx( i )
         d( i ) = dsigma( idxi )
         z( i ) = u2( idxi, 1 )
         coltyp( i ) = idxc( idxi )
   70 CONTINUE
*
*     Calculate the allowable deflation tolerance
*
      eps = dlamch( 'Epsilon' )
      tol = max( abs( alpha ), abs( beta ) )
      tol = eight*eps*max( abs( d( n ) ), tol )
*
*     There are 2 kinds of deflation -- first a value in the z-vector
*     is small, second two (or more) singular values are very close
*     together (their difference is small).
*
*     If the value in the z-vector is small, we simply permute the
*     array so that the corresponding singular value is moved to the
*     end.
*
*     If two values in the D-vector are close, we perform a two-sided
*     rotation designed to make one of the corresponding z-vector
*     entries zero, and then permute the array so that the deflated
*     singular value is moved to the end.
*
*     If there are multiple singular values then the problem deflates.
*     Here the number of equal singular values are found.  As each equal
*     singular value is found, an elementary reflector is computed to
*     rotate the corresponding singular subspace so that the
*     corresponding components of Z are zero in this new basis.
*
      k = 1
      k2 = n + 1
      DO 80 j = 2, n
         IF( abs( z( j ) ).LE.tol ) THEN
*
*           Deflate due to small z component.
*
            k2 = k2 - 1
            idxp( k2 ) = j
            coltyp( j ) = 4
            IF( j.EQ.n )
     $         GO TO 120
         ELSE
            jprev = j
            GO TO 90
         END IF
   80 CONTINUE
   90 CONTINUE
      j = jprev
  100 CONTINUE
      j = j + 1
      IF( j.GT.n )
     $   GO TO 110
      IF( abs( z( j ) ).LE.tol ) THEN
*
*        Deflate due to small z component.
*
         k2 = k2 - 1
         idxp( k2 ) = j
         coltyp( j ) = 4
      ELSE
*
*        Check if singular values are close enough to allow deflation.
*
         IF( abs( d( j )-d( jprev ) ).LE.tol ) THEN
*
*           Deflation is possible.
*
            s = z( jprev )
            c = z( j )
*
*           Find sqrt(a**2+b**2) without overflow or
*           destructive underflow.
*
            tau = dlapy2( c, s )
            c = c / tau
            s = -s / tau
            z( j ) = tau
            z( jprev ) = zero
*
*           Apply back the Givens rotation to the left and right
*           singular vector matrices.
*
            idxjp = idxq( idx( jprev )+1 )
            idxj = idxq( idx( j )+1 )
            IF( idxjp.LE.nlp1 ) THEN
               idxjp = idxjp - 1
            END IF
            IF( idxj.LE.nlp1 ) THEN
               idxj = idxj - 1
            END IF
            CALL drot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s )
            CALL drot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,
     $                 s )
            IF( coltyp( j ).NE.coltyp( jprev ) ) THEN
               coltyp( j ) = 3
            END IF
            coltyp( jprev ) = 4
            k2 = k2 - 1
            idxp( k2 ) = jprev
            jprev = j
         ELSE
            k = k + 1
            u2( k, 1 ) = z( jprev )
            dsigma( k ) = d( jprev )
            idxp( k ) = jprev
            jprev = j
         END IF
      END IF
      GO TO 100
  110 CONTINUE
*
*     Record the last singular value.
*
      k = k + 1
      u2( k, 1 ) = z( jprev )
      dsigma( k ) = d( jprev )
      idxp( k ) = jprev
*
  120 CONTINUE
*
*     Count up the total number of the various types of columns, then
*     form a permutation which positions the four column types into
*     four groups of uniform structure (although one or more of these
*     groups may be empty).
*
      DO 130 j = 1, 4
         ctot( j ) = 0
  130 CONTINUE
      DO 140 j = 2, n
         ct = coltyp( j )
         ctot( ct ) = ctot( ct ) + 1
  140 CONTINUE
*
*     PSM(*) = Position in SubMatrix (of types 1 through 4)
*
      psm( 1 ) = 2
      psm( 2 ) = 2 + ctot( 1 )
      psm( 3 ) = psm( 2 ) + ctot( 2 )
      psm( 4 ) = psm( 3 ) + ctot( 3 )
*
*     Fill out the IDXC 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, starting from the
*     second column. This applies similarly to the rows of VT.
*
      DO 150 j = 2, n
         jp = idxp( j )
         ct = coltyp( jp )
         idxc( psm( ct ) ) = j
         psm( ct ) = psm( ct ) + 1
  150 CONTINUE
*
*     Sort the singular values and corresponding singular vectors into
*     DSIGMA, U2, and VT2 respectively.  The singular values/vectors
*     which were not deflated go into the first K slots of DSIGMA, U2,
*     and VT2 respectively, while those which were deflated go into the
*     last N - K slots, except that the first column/row will be treated
*     separately.
*
      DO 160 j = 2, n
         jp = idxp( j )
         dsigma( j ) = d( jp )
         idxj = idxq( idx( idxp( idxc( j ) ) )+1 )
         IF( idxj.LE.nlp1 ) THEN
            idxj = idxj - 1
         END IF
         CALL dcopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 )
         CALL dcopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 )
  160 CONTINUE
*
*     Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
      dsigma( 1 ) = zero
      hlftol = tol / two
      IF( abs( dsigma( 2 ) ).LE.hlftol )
     $   dsigma( 2 ) = hlftol
      IF( m.GT.n ) THEN
         z( 1 ) = dlapy2( z1, z( m ) )
         IF( z( 1 ).LE.tol ) THEN
            c = one
            s = zero
            z( 1 ) = tol
         ELSE
            c = z1 / z( 1 )
            s = z( m ) / z( 1 )
         END IF
      ELSE
         IF( abs( z1 ).LE.tol ) THEN
            z( 1 ) = tol
         ELSE
            z( 1 ) = z1
         END IF
      END IF
*
*     Move the rest of the updating row to Z.
*
      CALL dcopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 )
*
*     Determine the first column of U2, the first row of VT2 and the
*     last row of VT.
*
      CALL dlaset( 'A', n, 1, zero, zero, u2, ldu2 )
      u2( nlp1, 1 ) = one
      IF( m.GT.n ) THEN
         DO 170 i = 1, nlp1
            vt( m, i ) = -s*vt( nlp1, i )
            vt2( 1, i ) = c*vt( nlp1, i )
  170    CONTINUE
         DO 180 i = nlp2, m
            vt2( 1, i ) = s*vt( m, i )
            vt( m, i ) = c*vt( m, i )
  180    CONTINUE
      ELSE
         CALL dcopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 )
      END IF
      IF( m.GT.n ) THEN
         CALL dcopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 )
      END IF
*
*     The deflated singular values and their corresponding vectors go
*     into the back of D, U, and V respectively.
*
      IF( n.GT.k ) THEN
         CALL dcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
         CALL dlacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),
     $                ldu )
         CALL dlacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),
     $                ldvt )
      END IF
*
*     Copy CTOT into COLTYP for referencing in DLASD3.
*
      DO 190 j = 1, 4
         coltyp( j ) = ctot( j )
  190 CONTINUE
*
      RETURN
*
*     End of DLASD2
*

dlasd3()

subroutine dlasd3	(	integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		double precision, dimension( * )	d,
		double precision, dimension( ldq, * )	q,
		integer	ldq,
		double precision, dimension( * )	dsigma,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldu2, * )	u2,
		integer	ldu2,
		double precision, dimension( ldvt, * )	vt,
		integer	ldvt,
		double precision, dimension( ldvt2, * )	vt2,
		integer	ldvt2,
		integer, dimension( * )	idxc,
		integer, dimension( * )	ctot,
		double precision, dimension( * )	z,
		integer	info )

DLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc.

Download DLASD3 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD3 finds all the square roots of the roots of the secular
!> equation, as defined by the values in D and Z.  It makes the
!> appropriate calls to DLASD4 and then updates the singular
!> vectors by matrix multiplication.
!>
!> 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 XMP, Cray YMP, Cray C 90, or Cray 2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
!> DLASD3 is called from DLASD1.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[in]	K	!> K is INTEGER !> The size of the secular equation, 1 =< K = < N. !>
[out]	D	!> D is DOUBLE PRECISION array, dimension(K) !> On exit the square roots of the roots of the secular equation, !> in ascending order. !>
[out]	Q	!> Q is DOUBLE PRECISION array, dimension (LDQ,K) !>
[in]	LDQ	!> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= K. !>
[in,out]	DSIGMA	!> DSIGMA is DOUBLE PRECISION array, dimension(K) !> The first K elements of this array contain the old roots !> of the deflated updating problem. These are the poles !> of the secular equation. !>
[out]	U	!> U is DOUBLE PRECISION array, dimension (LDU, N) !> The last N - K columns of this matrix contain the deflated !> left singular vectors. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= N. !>
[in]	U2	!> U2 is DOUBLE PRECISION array, dimension (LDU2, N) !> The first K columns of this matrix contain the non-deflated !> left singular vectors for the split problem. !>
[in]	LDU2	!> LDU2 is INTEGER !> The leading dimension of the array U2. LDU2 >= N. !>
[out]	VT	!> VT is DOUBLE PRECISION array, dimension (LDVT, M) !> The last M - K columns of VT**T contain the deflated !> right singular vectors. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= N. !>
[in,out]	VT2	!> VT2 is DOUBLE PRECISION array, dimension (LDVT2, N) !> The first K columns of VT2**T contain the non-deflated !> right singular vectors for the split problem. !>
[in]	LDVT2	!> LDVT2 is INTEGER !> The leading dimension of the array VT2. LDVT2 >= N. !>
[in]	IDXC	!> IDXC is INTEGER array, dimension ( N ) !> The permutation used to arrange the columns of U (and rows of !> VT) into three groups: the first group contains non-zero !> entries only at and above (or before) NL +1; the second !> contains non-zero entries only at and below (or after) NL+2; !> and the third is dense. The first column of U and the row of !> VT are treated separately, however. !> !> The rows of the singular vectors found by DLASD4 !> must be likewise permuted before the matrix multiplies can !> take place. !>
[in]	CTOT	!> CTOT is INTEGER array, dimension ( 4 ) !> A count of the total number of the various types of columns !> in U (or rows in VT), as described in IDXC. The fourth column !> type is any column which has been deflated. !>
[in,out]	Z	!> Z is DOUBLE PRECISION array, dimension (K) !> The first K elements of this array contain the components !> of the deflation-adjusted updating row vector. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 221 of file dlasd3.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
     $                   SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            CTOT( * ), IDXC( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO, NEGONE
      parameter( one = 1.0d+0, zero = 0.0d+0,
     $                   negone = -1.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
      DOUBLE PRECISION   RHO, TEMP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMC3, DNRM2
      EXTERNAL           dlamc3, dnrm2
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dgemm, dlacpy, dlascl, dlasd4, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) ) THEN
         info = -3
      END IF
*
      n = nl + nr + 1
      m = n + sqre
      nlp1 = nl + 1
      nlp2 = nl + 2
*
      IF( ( k.LT.1 ) .OR. ( k.GT.n ) ) THEN
         info = -4
      ELSE IF( ldq.LT.k ) THEN
         info = -7
      ELSE IF( ldu.LT.n ) THEN
         info = -10
      ELSE IF( ldu2.LT.n ) THEN
         info = -12
      ELSE IF( ldvt.LT.m ) THEN
         info = -14
      ELSE IF( ldvt2.LT.m ) THEN
         info = -16
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD3', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( k.EQ.1 ) THEN
         d( 1 ) = abs( z( 1 ) )
         CALL dcopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt )
         IF( z( 1 ).GT.zero ) THEN
            CALL dcopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 )
         ELSE
            DO 10 i = 1, n
               u( i, 1 ) = -u2( i, 1 )
   10       CONTINUE
         END IF
         RETURN
      END IF
*
*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
*     which on any of these machines zeros out the bottommost
*     bit of DSIGMA(I) if it is 1; this makes the subsequent
*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
*     occurs. On binary machines with a guard digit (almost all
*     machines) it does not change DSIGMA(I) at all. On hexadecimal
*     and decimal machines with a guard digit, it slightly
*     changes the bottommost bits of DSIGMA(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*DSIGMA(I) to prevent optimizing compilers from eliminating
*     this code.
*
      DO 20 i = 1, k
         dsigma( i ) = dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
   20 CONTINUE
*
*     Keep a copy of Z.
*
      CALL dcopy( k, z, 1, q, 1 )
*
*     Normalize Z.
*
      rho = dnrm2( k, z, 1 )
      CALL dlascl( 'G', 0, 0, rho, one, k, 1, z, k, info )
      rho = rho*rho
*
*     Find the new singular values.
*
      DO 30 j = 1, k
         CALL dlasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),
     $                vt( 1, j ), info )
*
*        If the zero finder fails, report the convergence failure.
*
         IF( info.NE.0 ) THEN
            RETURN
         END IF
   30 CONTINUE
*
*     Compute updated Z.
*
      DO 60 i = 1, k
         z( i ) = u( i, k )*vt( i, k )
         DO 40 j = 1, i - 1
            z( i ) = z( i )*( u( i, j )*vt( i, j ) /
     $               ( dsigma( i )-dsigma( j ) ) /
     $               ( dsigma( i )+dsigma( j ) ) )
   40    CONTINUE
         DO 50 j = i, k - 1
            z( i ) = z( i )*( u( i, j )*vt( i, j ) /
     $               ( dsigma( i )-dsigma( j+1 ) ) /
     $               ( dsigma( i )+dsigma( j+1 ) ) )
   50    CONTINUE
         z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) )
   60 CONTINUE
*
*     Compute left singular vectors of the modified diagonal matrix,
*     and store related information for the right singular vectors.
*
      DO 90 i = 1, k
         vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i )
         u( 1, i ) = negone
         DO 70 j = 2, k
            vt( j, i ) = z( j ) / u( j, i ) / vt( j, i )
            u( j, i ) = dsigma( j )*vt( j, i )
   70    CONTINUE
         temp = dnrm2( k, u( 1, i ), 1 )
         q( 1, i ) = u( 1, i ) / temp
         DO 80 j = 2, k
            jc = idxc( j )
            q( j, i ) = u( jc, i ) / temp
   80    CONTINUE
   90 CONTINUE
*
*     Update the left singular vector matrix.
*
      IF( k.EQ.2 ) THEN
         CALL dgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,
     $               ldu )
         GO TO 100
      END IF
      IF( ctot( 1 ).GT.0 ) THEN
         CALL dgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,
     $               q( 2, 1 ), ldq, zero, u( 1, 1 ), ldu )
         IF( ctot( 3 ).GT.0 ) THEN
            ktemp = 2 + ctot( 1 ) + ctot( 2 )
            CALL dgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
     $                  ldu2, q( ktemp, 1 ), ldq, one, u( 1, 1 ), ldu )
         END IF
      ELSE IF( ctot( 3 ).GT.0 ) THEN
         ktemp = 2 + ctot( 1 ) + ctot( 2 )
         CALL dgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
     $               ldu2, q( ktemp, 1 ), ldq, zero, u( 1, 1 ), ldu )
      ELSE
         CALL dlacpy( 'F', nl, k, u2, ldu2, u, ldu )
      END IF
      CALL dcopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu )
      ktemp = 2 + ctot( 1 )
      ctemp = ctot( 2 ) + ctot( 3 )
      CALL dgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,
     $            q( ktemp, 1 ), ldq, zero, u( nlp2, 1 ), ldu )
*
*     Generate the right singular vectors.
*
  100 CONTINUE
      DO 120 i = 1, k
         temp = dnrm2( k, vt( 1, i ), 1 )
         q( i, 1 ) = vt( 1, i ) / temp
         DO 110 j = 2, k
            jc = idxc( j )
            q( i, j ) = vt( jc, i ) / temp
  110    CONTINUE
  120 CONTINUE
*
*     Update the right singular vector matrix.
*
      IF( k.EQ.2 ) THEN
         CALL dgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,
     $               vt, ldvt )
         RETURN
      END IF
      ktemp = 1 + ctot( 1 )
      CALL dgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,
     $            vt2( 1, 1 ), ldvt2, zero, vt( 1, 1 ), ldvt )
      ktemp = 2 + ctot( 1 ) + ctot( 2 )
      IF( ktemp.LE.ldvt2 )
     $   CALL dgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),
     $               ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),
     $               ldvt )
*
      ktemp = ctot( 1 ) + 1
      nrp1 = nr + sqre
      IF( ktemp.GT.1 ) THEN
         DO 130 i = 1, k
            q( i, ktemp ) = q( i, 1 )
  130    CONTINUE
         DO 140 i = nlp2, m
            vt2( ktemp, i ) = vt2( 1, i )
  140    CONTINUE
      END IF
      ctemp = 1 + ctot( 2 ) + ctot( 3 )
      CALL dgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,
     $            vt2( ktemp, nlp2 ), ldvt2, zero, vt( 1, nlp2 ), ldvt )
*
      RETURN
*
*     End of DLASD3
*

dlasd4()

subroutine dlasd4	(	integer	n,
		integer	i,
		double precision, dimension( * )	d,
		double precision, dimension( * )	z,
		double precision, dimension( * )	delta,
		double precision	rho,
		double precision	sigma,
		double precision, dimension( * )	work,
		integer	info )

DLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by dbdsdc.

Download DLASD4 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This subroutine computes the square root of the I-th updated
!> eigenvalue of a positive symmetric rank-one modification to
!> a positive diagonal matrix whose entries are given as the squares
!> of the corresponding entries in the array d, and that
!>
!>        0 <= 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 ) * 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.
!> 

Parameters

[in]	N	!> N is INTEGER !> The length of all arrays. !>
[in]	I	!> I is INTEGER !> The index of the eigenvalue to be computed. 1 <= I <= N. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension ( N ) !> The original eigenvalues. It is assumed that they are in !> order, 0 <= D(I) < D(J) for I < J. !>
[in]	Z	!> Z is DOUBLE PRECISION array, dimension ( N ) !> The components of the updating vector. !>
[out]	DELTA	!> DELTA is DOUBLE PRECISION array, dimension ( N ) !> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th !> component. If N = 1, then DELTA(1) = 1. The vector DELTA !> contains the information necessary to construct the !> (singular) eigenvectors. !>
[in]	RHO	!> RHO is DOUBLE PRECISION !> The scalar in the symmetric updating formula. !>
[out]	SIGMA	!> SIGMA is DOUBLE PRECISION !> The computed sigma_I, the I-th updated eigenvalue. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension ( N ) !> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th !> component. If N = 1, then WORK( 1 ) = 1. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> > 0: if INFO = 1, the updating process failed. !>

Internal Parameters:

!>  Logical variable ORGATI (origin-at-i?) is used for distinguishing
!>  whether D(i) or D(i+1) is treated as the origin.
!>
!>            ORGATI = .true.    origin at i
!>            ORGATI = .false.   origin at i+1
!>
!>  Logical variable SWTCH3 (switch-for-3-poles?) is for noting
!>  if we are working with THREE poles!
!>
!>  MAXIT is the maximum number of iterations allowed for each
!>  eigenvalue.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 152 of file dlasd4.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            I, INFO, N
      DOUBLE PRECISION   RHO, SIGMA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DELTA( * ), WORK( * ), Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXIT
      parameter( maxit = 400 )
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
      parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
     $                   three = 3.0d+0, four = 4.0d+0, eight = 8.0d+0,
     $                   ten = 10.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ORGATI, SWTCH, SWTCH3, GEOMAVG
      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
      DOUBLE PRECISION   A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM,
     $                   DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
     $                   ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB,
     $                   SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DD( 3 ), ZZ( 3 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           dlaed6, dlasd5
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. 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
      IF( n.EQ.1 ) THEN
*
*        Presumably, I=1 upon entry
*
         sigma = sqrt( d( 1 )*d( 1 )+rho*z( 1 )*z( 1 ) )
         delta( 1 ) = one
         work( 1 ) = one
         RETURN
      END IF
      IF( n.EQ.2 ) THEN
         CALL dlasd5( i, d, z, delta, rho, sigma, work )
         RETURN
      END IF
*
*     Compute machine epsilon
*
      eps = dlamch( 'Epsilon' )
      rhoinv = one / rho
      tau2= zero
*
*     The case I = N
*
      IF( i.EQ.n ) THEN
*
*        Initialize some basic variables
*
         ii = n - 1
         niter = 1
*
*        Calculate initial guess
*
         temp = rho / two
*
*        If ||Z||_2 is not one, then TEMP should be set to
*        RHO * ||Z||_2^2 / TWO
*
         temp1 = temp / ( d( n )+sqrt( d( n )*d( n )+temp ) )
         DO 10 j = 1, n
            work( j ) = d( j ) + d( n ) + temp1
            delta( j ) = ( d( j )-d( n ) ) - temp1
   10    CONTINUE
*
         psi = zero
         DO 20 j = 1, n - 2
            psi = psi + z( j )*z( j ) / ( delta( j )*work( j ) )
   20    CONTINUE
*
         c = rhoinv + psi
         w = c + z( ii )*z( ii ) / ( delta( ii )*work( ii ) ) +
     $       z( n )*z( n ) / ( delta( n )*work( n ) )
*
         IF( w.LE.zero ) THEN
            temp1 = sqrt( d( n )*d( n )+rho )
            temp = z( n-1 )*z( n-1 ) / ( ( d( n-1 )+temp1 )*
     $             ( d( n )-d( n-1 )+rho / ( d( n )+temp1 ) ) ) +
     $             z( n )*z( n ) / rho
*
*           The following TAU2 is to approximate
*           SIGMA_n^2 - D( N )*D( N )
*
            IF( c.LE.temp ) THEN
               tau = rho
            ELSE
               delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) )
               a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n )
               b = z( n )*z( n )*delsq
               IF( a.LT.zero ) THEN
                  tau2 = two*b / ( sqrt( a*a+four*b*c )-a )
               ELSE
                  tau2 = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
               END IF
               tau = tau2 / ( d( n )+sqrt( d( n )*d( n )+tau2 ) )
            END IF
*
*           It can be proved that
*               D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO
*
         ELSE
            delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) )
            a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n )
            b = z( n )*z( n )*delsq
*
*           The following TAU2 is to approximate
*           SIGMA_n^2 - D( N )*D( N )
*
            IF( a.LT.zero ) THEN
               tau2 = two*b / ( sqrt( a*a+four*b*c )-a )
            ELSE
               tau2 = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
            END IF
            tau = tau2 / ( d( n )+sqrt( d( n )*d( n )+tau2 ) )
 
*
*           It can be proved that
*           D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2
*
         END IF
*
*        The following TAU is to approximate SIGMA_n - D( N )
*
*         TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) )
*
         sigma = d( n ) + tau
         DO 30 j = 1, n
            delta( j ) = ( d( j )-d( n ) ) - tau
            work( j ) = d( j ) + d( n ) + tau
   30    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 40 j = 1, ii
            temp = z( j ) / ( delta( j )*work( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
   40    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         temp = z( n ) / ( delta( n )*work( n ) )
         phi = z( n )*temp
         dphi = temp*temp
         erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $          + ABS( TAU2 )*( DPSI+DPHI )
*
         w = rhoinv + phi + psi
*
*        Test for convergence
*
         IF( abs( w ).LE.eps*erretm ) THEN
            GO TO 240
         END IF
*
*        Calculate the new step
*
         niter = niter + 1
         dtnsq1 = work( n-1 )*delta( n-1 )
         dtnsq = work( n )*delta( n )
         c = w - dtnsq1*dpsi - dtnsq*dphi
         a = ( dtnsq+dtnsq1 )*w - dtnsq*dtnsq1*( dpsi+dphi )
         b = dtnsq*dtnsq1*w
         IF( c.LT.zero )
     $      c = abs( c )
         IF( c.EQ.zero ) THEN
            eta = rho - sigma*sigma
         ELSE IF( a.GE.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.GT.zero )
     $      eta = -w / ( dpsi+dphi )
         temp = eta - dtnsq
         IF( temp.GT.rho )
     $      eta = rho + dtnsq
*
         eta = eta / ( sigma+sqrt( eta+sigma*sigma ) )
         tau = tau + eta
         sigma = sigma + eta
*
         DO 50 j = 1, n
            delta( j ) = delta( j ) - eta
            work( j ) = work( j ) + eta
   50    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 60 j = 1, ii
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
   60    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         tau2 = work( n )*delta( n )
         temp = z( n ) / tau2
         phi = z( n )*temp
         dphi = temp*temp
         erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $          + ABS( TAU2 )*( DPSI+DPHI )
*
         w = rhoinv + phi + psi
*
*        Main loop to update the values of the array   DELTA
*
         iter = niter + 1
*
         DO 90 niter = iter, maxit
*
*           Test for convergence
*
            IF( abs( w ).LE.eps*erretm ) THEN
               GO TO 240
            END IF
*
*           Calculate the new step
*
            dtnsq1 = work( n-1 )*delta( n-1 )
            dtnsq = work( n )*delta( n )
            c = w - dtnsq1*dpsi - dtnsq*dphi
            a = ( dtnsq+dtnsq1 )*w - dtnsq1*dtnsq*( dpsi+dphi )
            b = dtnsq1*dtnsq*w
            IF( a.GE.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.GT.zero )
     $         eta = -w / ( dpsi+dphi )
            temp = eta - dtnsq
            IF( temp.LE.zero )
     $         eta = eta / two
*
            eta = eta / ( sigma+sqrt( eta+sigma*sigma ) )
            tau = tau + eta
            sigma = sigma + eta
*
            DO 70 j = 1, n
               delta( j ) = delta( j ) - eta
               work( j ) = work( j ) + eta
   70       CONTINUE
*
*           Evaluate PSI and the derivative DPSI
*
            dpsi = zero
            psi = zero
            erretm = zero
            DO 80 j = 1, ii
               temp = z( j ) / ( work( j )*delta( j ) )
               psi = psi + z( j )*temp
               dpsi = dpsi + temp*temp
               erretm = erretm + psi
   80       CONTINUE
            erretm = abs( erretm )
*
*           Evaluate PHI and the derivative DPHI
*
            tau2 = work( n )*delta( n )
            temp = z( n ) / tau2
            phi = z( n )*temp
            dphi = temp*temp
            erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $             + ABS( TAU2 )*( DPSI+DPHI )
*
            w = rhoinv + phi + psi
   90    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         info = 1
         GO TO 240
*
*        End for the case I = N
*
      ELSE
*
*        The case for I < N
*
         niter = 1
         ip1 = i + 1
*
*        Calculate initial guess
*
         delsq = ( d( ip1 )-d( i ) )*( d( ip1 )+d( i ) )
         delsq2 = delsq / two
         sq2=sqrt( ( d( i )*d( i )+d( ip1 )*d( ip1 ) ) / two )
         temp = delsq2 / ( d( i )+sq2 )
         DO 100 j = 1, n
            work( j ) = d( j ) + d( i ) + temp
            delta( j ) = ( d( j )-d( i ) ) - temp
  100    CONTINUE
*
         psi = zero
         DO 110 j = 1, i - 1
            psi = psi + z( j )*z( j ) / ( work( j )*delta( j ) )
  110    CONTINUE
*
         phi = zero
         DO 120 j = n, i + 2, -1
            phi = phi + z( j )*z( j ) / ( work( j )*delta( j ) )
  120    CONTINUE
         c = rhoinv + psi + phi
         w = c + z( i )*z( i ) / ( work( i )*delta( i ) ) +
     $       z( ip1 )*z( ip1 ) / ( work( ip1 )*delta( ip1 ) )
*
         geomavg = .false.
         IF( w.GT.zero ) THEN
*
*           d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
*           We choose d(i) as origin.
*
            orgati = .true.
            ii = i
            sglb = zero
            sgub = delsq2  / ( d( i )+sq2 )
            a = c*delsq + z( i )*z( i ) + z( ip1 )*z( ip1 )
            b = z( i )*z( i )*delsq
            IF( a.GT.zero ) THEN
               tau2 = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
            ELSE
               tau2 = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
            END IF
*
*           TAU2 now is an estimation of SIGMA^2 - D( I )^2. The
*           following, however, is the corresponding estimation of
*           SIGMA - D( I ).
*
            tau = tau2 / ( d( i )+sqrt( d( i )*d( i )+tau2 ) )
            temp = sqrt(eps)
            IF( (d(i).LE.temp*d(ip1)).AND.(abs(z(i)).LE.temp)
     $                               .AND.(d(i).GT.zero) ) THEN
               tau = min( ten*d(i), sgub )
               geomavg = .true.
            END IF
         ELSE
*
*           (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
*           We choose d(i+1) as origin.
*
            orgati = .false.
            ii = ip1
            sglb = -delsq2  / ( d( ii )+sq2 )
            sgub = zero
            a = c*delsq - z( i )*z( i ) - z( ip1 )*z( ip1 )
            b = z( ip1 )*z( ip1 )*delsq
            IF( a.LT.zero ) THEN
               tau2 = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
            ELSE
               tau2 = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
            END IF
*
*           TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The
*           following, however, is the corresponding estimation of
*           SIGMA - D( IP1 ).
*
            tau = tau2 / ( d( ip1 )+sqrt( abs( d( ip1 )*d( ip1 )+
     $            tau2 ) ) )
         END IF
*
         sigma = d( ii ) + tau
         DO 130 j = 1, n
            work( j ) = d( j ) + d( ii ) + tau
            delta( j ) = ( d( j )-d( ii ) ) - tau
  130    CONTINUE
         iim1 = ii - 1
         iip1 = ii + 1
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 150 j = 1, iim1
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
  150    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         dphi = zero
         phi = zero
         DO 160 j = n, iip1, -1
            temp = z( j ) / ( work( j )*delta( j ) )
            phi = phi + z( j )*temp
            dphi = dphi + temp*temp
            erretm = erretm + phi
  160    CONTINUE
*
         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.LT.zero )
     $         swtch3 = .true.
         ELSE
            IF( w.GT.zero )
     $         swtch3 = .true.
         END IF
         IF( ii.EQ.1 .OR. ii.EQ.n )
     $      swtch3 = .false.
*
         temp = z( ii ) / ( work( 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( TAU2 )*DW
*
*        Test for convergence
*
         IF( abs( w ).LE.eps*erretm ) THEN
            GO TO 240
         END IF
*
         IF( w.LE.zero ) THEN
            sglb = max( sglb, tau )
         ELSE
            sgub = min( sgub, tau )
         END IF
*
*        Calculate the new step
*
         niter = niter + 1
         IF( .NOT.swtch3 ) THEN
            dtipsq = work( ip1 )*delta( ip1 )
            dtisq = work( i )*delta( i )
            IF( orgati ) THEN
               c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
            ELSE
               c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
            END IF
            a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
            b = dtipsq*dtisq*w
            IF( c.EQ.zero ) THEN
               IF( a.EQ.zero ) THEN
                  IF( orgati ) THEN
                     a = z( i )*z( i ) + dtipsq*dtipsq*( dpsi+dphi )
                  ELSE
                     a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi )
                  END IF
               END IF
               eta = b / a
            ELSE IF( a.LE.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
*
            dtiim = work( iim1 )*delta( iim1 )
            dtiip = work( iip1 )*delta( iip1 )
            temp = rhoinv + psi + phi
            IF( orgati ) THEN
               temp1 = z( iim1 ) / dtiim
               temp1 = temp1*temp1
               c = ( temp - dtiip*( dpsi+dphi ) ) -
     $             ( d( iim1 )-d( iip1 ) )*( d( iim1 )+d( iip1 ) )*temp1
               zz( 1 ) = z( iim1 )*z( iim1 )
               IF( dpsi.LT.temp1 ) THEN
                  zz( 3 ) = dtiip*dtiip*dphi
               ELSE
                  zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi )
               END IF
            ELSE
               temp1 = z( iip1 ) / dtiip
               temp1 = temp1*temp1
               c = ( temp - dtiim*( dpsi+dphi ) ) -
     $             ( d( iip1 )-d( iim1 ) )*( d( iim1 )+d( iip1 ) )*temp1
               IF( dphi.LT.temp1 ) THEN
                  zz( 1 ) = dtiim*dtiim*dpsi
               ELSE
                  zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) )
               END IF
               zz( 3 ) = z( iip1 )*z( iip1 )
            END IF
            zz( 2 ) = z( ii )*z( ii )
            dd( 1 ) = dtiim
            dd( 2 ) = delta( ii )*work( ii )
            dd( 3 ) = dtiip
            CALL dlaed6( niter, orgati, c, dd, zz, w, eta, info )
*
            IF( info.NE.0 ) THEN
*
*              If INFO is not 0, i.e., DLAED6 failed, switch back
*              to 2 pole interpolation.
*
               swtch3 = .false.
               info = 0
               dtipsq = work( ip1 )*delta( ip1 )
               dtisq = work( i )*delta( i )
               IF( orgati ) THEN
                  c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
               ELSE
                  c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
               END IF
               a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
               b = dtipsq*dtisq*w
               IF( c.EQ.zero ) THEN
                  IF( a.EQ.zero ) THEN
                     IF( orgati ) THEN
                        a = z( i )*z( i ) + dtipsq*dtipsq*( dpsi+dphi )
                     ELSE
                        a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi)
                     END IF
                  END IF
                  eta = b / a
               ELSE IF( a.LE.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
            END IF
         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.GE.zero )
     $      eta = -w / dw
*
         eta = eta / ( sigma+sqrt( sigma*sigma+eta ) )
         temp = tau + eta
         IF( temp.GT.sgub .OR. temp.LT.sglb ) THEN
            IF( w.LT.zero ) THEN
               eta = ( sgub-tau ) / two
            ELSE
               eta = ( sglb-tau ) / two
            END IF
            IF( geomavg ) THEN
               IF( w .LT. zero ) THEN
                  IF( tau .GT. zero ) THEN
                     eta = sqrt(sgub*tau)-tau
                  END IF
               ELSE
                  IF( sglb .GT. zero ) THEN
                     eta = sqrt(sglb*tau)-tau
                  END IF
               END IF
            END IF
         END IF
*
         prew = w
*
         tau = tau + eta
         sigma = sigma + eta
*
         DO 170 j = 1, n
            work( j ) = work( j ) + eta
            delta( j ) = delta( j ) - eta
  170    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 180 j = 1, iim1
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
  180    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         dphi = zero
         phi = zero
         DO 190 j = n, iip1, -1
            temp = z( j ) / ( work( j )*delta( j ) )
            phi = phi + z( j )*temp
            dphi = dphi + temp*temp
            erretm = erretm + phi
  190    CONTINUE
*
         tau2 = work( ii )*delta( ii )
         temp = z( ii ) / tau2
         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( TAU2 )*DW
*
         swtch = .false.
         IF( orgati ) THEN
            IF( -w.GT.abs( prew ) / ten )
     $         swtch = .true.
         ELSE
            IF( w.GT.abs( prew ) / ten )
     $         swtch = .true.
         END IF
*
*        Main loop to update the values of the array   DELTA and WORK
*
         iter = niter + 1
*
         DO 230 niter = iter, maxit
*
*           Test for convergence
*
            IF( abs( w ).LE.eps*erretm ) THEN
*     $          .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN
               GO TO 240
            END IF
*
            IF( w.LE.zero ) THEN
               sglb = max( sglb, tau )
            ELSE
               sgub = min( sgub, tau )
            END IF
*
*           Calculate the new step
*
            IF( .NOT.swtch3 ) THEN
               dtipsq = work( ip1 )*delta( ip1 )
               dtisq = work( i )*delta( i )
               IF( .NOT.swtch ) THEN
                  IF( orgati ) THEN
                     c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
                  ELSE
                     c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
                  END IF
               ELSE
                  temp = z( ii ) / ( work( ii )*delta( ii ) )
                  IF( orgati ) THEN
                     dpsi = dpsi + temp*temp
                  ELSE
                     dphi = dphi + temp*temp
                  END IF
                  c = w - dtisq*dpsi - dtipsq*dphi
               END IF
               a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
               b = dtipsq*dtisq*w
               IF( c.EQ.zero ) THEN
                  IF( a.EQ.zero ) THEN
                     IF( .NOT.swtch ) THEN
                        IF( orgati ) THEN
                           a = z( i )*z( i ) + dtipsq*dtipsq*
     $                         ( dpsi+dphi )
                        ELSE
                           a = z( ip1 )*z( ip1 ) +
     $                         dtisq*dtisq*( dpsi+dphi )
                        END IF
                     ELSE
                        a = dtisq*dtisq*dpsi + dtipsq*dtipsq*dphi
                     END IF
                  END IF
                  eta = b / a
               ELSE IF( a.LE.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
*
               dtiim = work( iim1 )*delta( iim1 )
               dtiip = work( iip1 )*delta( iip1 )
               temp = rhoinv + psi + phi
               IF( swtch ) THEN
                  c = temp - dtiim*dpsi - dtiip*dphi
                  zz( 1 ) = dtiim*dtiim*dpsi
                  zz( 3 ) = dtiip*dtiip*dphi
               ELSE
                  IF( orgati ) THEN
                     temp1 = z( iim1 ) / dtiim
                     temp1 = temp1*temp1
                     temp2 = ( d( iim1 )-d( iip1 ) )*
     $                       ( d( iim1 )+d( iip1 ) )*temp1
                     c = temp - dtiip*( dpsi+dphi ) - temp2
                     zz( 1 ) = z( iim1 )*z( iim1 )
                     IF( dpsi.LT.temp1 ) THEN
                        zz( 3 ) = dtiip*dtiip*dphi
                     ELSE
                        zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi )
                     END IF
                  ELSE
                     temp1 = z( iip1 ) / dtiip
                     temp1 = temp1*temp1
                     temp2 = ( d( iip1 )-d( iim1 ) )*
     $                       ( d( iim1 )+d( iip1 ) )*temp1
                     c = temp - dtiim*( dpsi+dphi ) - temp2
                     IF( dphi.LT.temp1 ) THEN
                        zz( 1 ) = dtiim*dtiim*dpsi
                     ELSE
                        zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) )
                     END IF
                     zz( 3 ) = z( iip1 )*z( iip1 )
                  END IF
               END IF
               dd( 1 ) = dtiim
               dd( 2 ) = delta( ii )*work( ii )
               dd( 3 ) = dtiip
               CALL dlaed6( niter, orgati, c, dd, zz, w, eta, info )
*
               IF( info.NE.0 ) THEN
*
*                 If INFO is not 0, i.e., DLAED6 failed, switch
*                 back to two pole interpolation
*
                  swtch3 = .false.
                  info = 0
                  dtipsq = work( ip1 )*delta( ip1 )
                  dtisq = work( i )*delta( i )
                  IF( .NOT.swtch ) THEN
                     IF( orgati ) THEN
                        c = w - dtipsq*dw + delsq*( z( i )/dtisq )**2
                     ELSE
                        c = w - dtisq*dw - delsq*( z( ip1 )/dtipsq )**2
                     END IF
                  ELSE
                     temp = z( ii ) / ( work( ii )*delta( ii ) )
                     IF( orgati ) THEN
                        dpsi = dpsi + temp*temp
                     ELSE
                        dphi = dphi + temp*temp
                     END IF
                     c = w - dtisq*dpsi - dtipsq*dphi
                  END IF
                  a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
                  b = dtipsq*dtisq*w
                  IF( c.EQ.zero ) THEN
                     IF( a.EQ.zero ) THEN
                        IF( .NOT.swtch ) THEN
                           IF( orgati ) THEN
                              a = z( i )*z( i ) + dtipsq*dtipsq*
     $                            ( dpsi+dphi )
                           ELSE
                              a = z( ip1 )*z( ip1 ) +
     $                            dtisq*dtisq*( dpsi+dphi )
                           END IF
                        ELSE
                           a = dtisq*dtisq*dpsi + dtipsq*dtipsq*dphi
                        END IF
                     END IF
                     eta = b / a
                  ELSE IF( a.LE.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
               END IF
            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.GE.zero )
     $         eta = -w / dw
*
            eta = eta / ( sigma+sqrt( sigma*sigma+eta ) )
            temp=tau+eta
            IF( temp.GT.sgub .OR. temp.LT.sglb ) THEN
               IF( w.LT.zero ) THEN
                  eta = ( sgub-tau ) / two
               ELSE
                  eta = ( sglb-tau ) / two
               END IF
               IF( geomavg ) THEN
                  IF( w .LT. zero ) THEN
                     IF( tau .GT. zero ) THEN
                        eta = sqrt(sgub*tau)-tau
                     END IF
                  ELSE
                     IF( sglb .GT. zero ) THEN
                        eta = sqrt(sglb*tau)-tau
                     END IF
                  END IF
               END IF
            END IF
*
            prew = w
*
            tau = tau + eta
            sigma = sigma + eta
*
            DO 200 j = 1, n
               work( j ) = work( j ) + eta
               delta( j ) = delta( j ) - eta
  200       CONTINUE
*
*           Evaluate PSI and the derivative DPSI
*
            dpsi = zero
            psi = zero
            erretm = zero
            DO 210 j = 1, iim1
               temp = z( j ) / ( work( j )*delta( j ) )
               psi = psi + z( j )*temp
               dpsi = dpsi + temp*temp
               erretm = erretm + psi
  210       CONTINUE
            erretm = abs( erretm )
*
*           Evaluate PHI and the derivative DPHI
*
            dphi = zero
            phi = zero
            DO 220 j = n, iip1, -1
               temp = z( j ) / ( work( j )*delta( j ) )
               phi = phi + z( j )*temp
               dphi = dphi + temp*temp
               erretm = erretm + phi
  220       CONTINUE
*
            tau2 = work( ii )*delta( ii )
            temp = z( ii ) / tau2
            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( TAU2 )*DW
*
            IF( w*prew.GT.zero .AND. abs( w ).GT.abs( prew ) / ten )
     $         swtch = .NOT.swtch
*
  230    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         info = 1
*
      END IF
*
  240 CONTINUE
      RETURN
*
*     End of DLASD4
*

dlasd5()

subroutine dlasd5	(	integer	i,
		double precision, dimension( 2 )	d,
		double precision, dimension( 2 )	z,
		double precision, dimension( 2 )	delta,
		double precision	rho,
		double precision	dsigma,
		double precision, dimension( 2 )	work )

DLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc.

Download DLASD5 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This subroutine computes the square root of the I-th eigenvalue
!> of a positive symmetric rank-one modification of a 2-by-2 diagonal
!> matrix
!>
!>            diag( D ) * diag( D ) +  RHO * Z * transpose(Z) .
!>
!> The diagonal entries in the array D are assumed to satisfy
!>
!>            0 <= D(i) < D(j)  for  i < j .
!>
!> We also assume RHO > 0 and that the Euclidean norm of the vector
!> Z is one.
!> 

Parameters

[in]	I	!> I is INTEGER !> The index of the eigenvalue to be computed. I = 1 or I = 2. !>
[in]	D	!> D is DOUBLE PRECISION array, dimension ( 2 ) !> The original eigenvalues. We assume 0 <= D(1) < D(2). !>
[in]	Z	!> Z is DOUBLE PRECISION array, dimension ( 2 ) !> The components of the updating vector. !>
[out]	DELTA	!> DELTA is DOUBLE PRECISION array, dimension ( 2 ) !> Contains (D(j) - sigma_I) in its j-th component. !> The vector DELTA contains the information necessary !> to construct the eigenvectors. !>
[in]	RHO	!> RHO is DOUBLE PRECISION !> The scalar in the symmetric updating formula. !>
[out]	DSIGMA	!> DSIGMA is DOUBLE PRECISION !> The computed sigma_I, the I-th updated eigenvalue. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension ( 2 ) !> WORK contains (D(j) + sigma_I) in its j-th component. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 115 of file dlasd5.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            I
      DOUBLE PRECISION   DSIGMA, RHO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE, FOUR
      parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
     $                   three = 3.0d+0, four = 4.0d+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   B, C, DEL, DELSQ, TAU, W
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
      del = d( 2 ) - d( 1 )
      delsq = del*( d( 2 )+d( 1 ) )
      IF( i.EQ.1 ) THEN
         w = one + four*rho*( z( 2 )*z( 2 ) / ( d( 1 )+three*d( 2 ) )-
     $       z( 1 )*z( 1 ) / ( three*d( 1 )+d( 2 ) ) ) / del
         IF( w.GT.zero ) THEN
            b = delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
            c = rho*z( 1 )*z( 1 )*delsq
*
*           B > ZERO, always
*
*           The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
            tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
*
*           The following TAU is DSIGMA - D( 1 )
*
            tau = tau / ( d( 1 )+sqrt( d( 1 )*d( 1 )+tau ) )
            dsigma = d( 1 ) + tau
            delta( 1 ) = -tau
            delta( 2 ) = del - tau
            work( 1 ) = two*d( 1 ) + tau
            work( 2 ) = ( d( 1 )+tau ) + d( 2 )
*           DELTA( 1 ) = -Z( 1 ) / TAU
*           DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
         ELSE
            b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
            c = rho*z( 2 )*z( 2 )*delsq
*
*           The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
            IF( b.GT.zero ) THEN
               tau = -two*c / ( b+sqrt( b*b+four*c ) )
            ELSE
               tau = ( b-sqrt( b*b+four*c ) ) / two
            END IF
*
*           The following TAU is DSIGMA - D( 2 )
*
            tau = tau / ( d( 2 )+sqrt( abs( d( 2 )*d( 2 )+tau ) ) )
            dsigma = d( 2 ) + tau
            delta( 1 ) = -( del+tau )
            delta( 2 ) = -tau
            work( 1 ) = d( 1 ) + tau + d( 2 )
            work( 2 ) = two*d( 2 ) + tau
*           DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
*           DELTA( 2 ) = -Z( 2 ) / TAU
         END IF
*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
*        DELTA( 1 ) = DELTA( 1 ) / TEMP
*        DELTA( 2 ) = DELTA( 2 ) / TEMP
      ELSE
*
*        Now I=2
*
         b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
         c = rho*z( 2 )*z( 2 )*delsq
*
*        The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
         IF( b.GT.zero ) THEN
            tau = ( b+sqrt( b*b+four*c ) ) / two
         ELSE
            tau = two*c / ( -b+sqrt( b*b+four*c ) )
         END IF
*
*        The following TAU is DSIGMA - D( 2 )
*
         tau = tau / ( d( 2 )+sqrt( d( 2 )*d( 2 )+tau ) )
         dsigma = d( 2 ) + tau
         delta( 1 ) = -( del+tau )
         delta( 2 ) = -tau
         work( 1 ) = d( 1 ) + tau + d( 2 )
         work( 2 ) = two*d( 2 ) + tau
*        DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
*        DELTA( 2 ) = -Z( 2 ) / TAU
*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
*        DELTA( 1 ) = DELTA( 1 ) / TEMP
*        DELTA( 2 ) = DELTA( 2 ) / TEMP
      END IF
      RETURN
*
*     End of DLASD5
*

dlasd6()

subroutine dlasd6	(	integer	icompq,
		integer	nl,
		integer	nr,
		integer	sqre,
		double precision, dimension( * )	d,
		double precision, dimension( * )	vf,
		double precision, dimension( * )	vl,
		double precision	alpha,
		double precision	beta,
		integer, dimension( * )	idxq,
		integer, dimension( * )	perm,
		integer	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		double precision, dimension( ldgnum, * )	givnum,
		integer	ldgnum,
		double precision, dimension( ldgnum, * )	poles,
		double precision, dimension( * )	difl,
		double precision, dimension( * )	difr,
		double precision, dimension( * )	z,
		integer	k,
		double precision	c,
		double precision	s,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

DLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc.

Download DLASD6 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD6 computes the SVD of an updated upper bidiagonal matrix B
!> obtained by merging two smaller ones by appending a row. This
!> routine is used only for the problem which requires all singular
!> values and optionally singular vector matrices in factored form.
!> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
!> A related subroutine, DLASD1, handles the case in which all singular
!> values and singular vectors of the bidiagonal matrix are desired.
!>
!> DLASD6 computes the SVD as follows:
!>
!>               ( D1(in)    0    0       0 )
!>   B = U(in) * (   Z1**T   a   Z2**T    b ) * VT(in)
!>               (   0       0   D2(in)   0 )
!>
!>     = U(out) * ( D(out) 0) * VT(out)
!>
!> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M
!> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!> elsewhere; and the entry b is empty if SQRE = 0.
!>
!> The singular values of B can be computed using D1, D2, the first
!> components of all the right singular vectors of the lower block, and
!> the last components of all the right singular vectors of the upper
!> block. These components are stored and updated in VF and VL,
!> respectively, in DLASD6. Hence U and VT are not explicitly
!> referenced.
!>
!> The singular values are stored in D. The algorithm consists of two
!> stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple singular values 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 DLASD7.
!>
!>       The second stage consists of calculating the updated
!>       singular values. This is done by finding the roots of the
!>       secular equation via the routine DLASD4 (as called by DLASD8).
!>       This routine also updates VF and VL and computes the distances
!>       between the updated singular values and the old singular
!>       values.
!>
!> DLASD6 is called from DLASDA.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed in !> factored form: !> = 0: Compute singular values only. !> = 1: Compute singular vectors in factored form as well. !>
[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has row dimension N = NL + NR + 1, !> and column dimension M = N + SQRE. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension ( NL+NR+1 ). !> On entry D(1:NL,1:NL) contains the singular values of the !> upper block, and D(NL+2:N) contains the singular values !> of the lower block. On exit D(1:N) contains the singular !> values of the modified matrix. !>
[in,out]	VF	!> VF is DOUBLE PRECISION array, dimension ( M ) !> On entry, VF(1:NL+1) contains the first components of all !> right singular vectors of the upper block; and VF(NL+2:M) !> contains the first components of all right singular vectors !> of the lower block. On exit, VF contains the first components !> of all right singular vectors of the bidiagonal matrix. !>
[in,out]	VL	!> VL is DOUBLE PRECISION array, dimension ( M ) !> On entry, VL(1:NL+1) contains the last components of all !> right singular vectors of the upper block; and VL(NL+2:M) !> contains the last components of all right singular vectors of !> the lower block. On exit, VL contains the last components of !> all right singular vectors of the bidiagonal matrix. !>
[in,out]	ALPHA	!> ALPHA is DOUBLE PRECISION !> Contains the diagonal element associated with the added row. !>
[in,out]	BETA	!> BETA is DOUBLE PRECISION !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension ( N ) !> This contains the permutation which will reintegrate the !> subproblem just solved back into sorted order, i.e. !> D( IDXQ( I = 1, N ) ) will be in ascending order. !>
[out]	PERM	!> PERM is INTEGER array, dimension ( N ) !> The permutations (from deflation and sorting) to be applied !> to each block. Not referenced if ICOMPQ = 0. !>
[out]	GIVPTR	!> GIVPTR is INTEGER !> The number of Givens rotations which took place in this !> subproblem. Not referenced if ICOMPQ = 0. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGCOL	!> LDGCOL is INTEGER !> leading dimension of GIVCOL, must be at least N. !>
[out]	GIVNUM	!> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) !> Each number indicates the C or S value to be used in the !> corresponding Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGNUM	!> LDGNUM is INTEGER !> The leading dimension of GIVNUM and POLES, must be at least N. !>
[out]	POLES	!> POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) !> On exit, POLES(1,*) is an array containing the new singular !> values obtained from solving the secular equation, and !> POLES(2,*) is an array containing the poles in the secular !> equation. Not referenced if ICOMPQ = 0. !>
[out]	DIFL	!> DIFL is DOUBLE PRECISION array, dimension ( N ) !> On exit, DIFL(I) is the distance between I-th updated !> (undeflated) singular value and the I-th (undeflated) old !> singular value. !>
[out]	DIFR	!> DIFR is DOUBLE PRECISION array, !> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and !> dimension ( K ) if ICOMPQ = 0. !> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not !> defined and will not be referenced. !> !> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the !> normalizing factors for the right singular vector matrix. !> !> See DLASD8 for details on DIFL and DIFR. !>
[out]	Z	!> Z is DOUBLE PRECISION array, dimension ( M ) !> The first elements of this array contain the components !> of the deflation-adjusted updating row vector. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, !> This is the order of the related secular equation. 1 <= K <=N. !>
[out]	C	!> C is DOUBLE PRECISION !> C contains garbage if SQRE =0 and the C-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	S	!> S is DOUBLE PRECISION !> S contains garbage if SQRE =0 and the S-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension ( 4 * M ) !>
[out]	IWORK	!> IWORK is INTEGER array, dimension ( 3 * N ) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 309 of file dlasd6.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
     $                   NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA, C, S
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
     $                   PERM( * )
      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( * ),
     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
     $                   VF( * ), VL( * ), WORK( * ), Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
     $                   N, N1, N2
      DOUBLE PRECISION   ORGNRM
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlamrg, dlascl, dlasd7, dlasd8, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      n = nl + nr + 1
      m = n + sqre
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( nl.LT.1 ) THEN
         info = -2
      ELSE IF( nr.LT.1 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldgcol.LT.n ) THEN
         info = -14
      ELSE IF( ldgnum.LT.n ) THEN
         info = -16
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD6', -info )
         RETURN
      END IF
*
*     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 DLASD7 and DLASD8.
*
      isigma = 1
      iw = isigma + n
      ivfw = iw + m
      ivlw = ivfw + m
*
      idx = 1
      idxc = idx + n
      idxp = idxc + n
*
*     Scale.
*
      orgnrm = max( abs( alpha ), abs( beta ) )
      d( nl+1 ) = zero
      DO 10 i = 1, n
         IF( abs( d( i ) ).GT.orgnrm ) THEN
            orgnrm = abs( d( i ) )
         END IF
   10 CONTINUE
      CALL dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
      alpha = alpha / orgnrm
      beta = beta / orgnrm
*
*     Sort and Deflate singular values.
*
      CALL dlasd7( icompq, nl, nr, sqre, k, d, z, work( iw ), vf,
     $             work( ivfw ), vl, work( ivlw ), alpha, beta,
     $             work( isigma ), iwork( idx ), iwork( idxp ), idxq,
     $             perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s,
     $             info )
*
*     Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
      CALL dlasd8( icompq, k, d, z, vf, vl, difl, difr, ldgnum,
     $             work( isigma ), work( iw ), info )
*
*     Report the possible convergence failure.
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
*
*     Save the poles if ICOMPQ = 1.
*
      IF( icompq.EQ.1 ) THEN
         CALL dcopy( k, d, 1, poles( 1, 1 ), 1 )
         CALL dcopy( k, work( isigma ), 1, poles( 1, 2 ), 1 )
      END IF
*
*     Unscale.
*
      CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
*
*     Prepare the IDXQ sorting permutation.
*
      n1 = k
      n2 = n - k
      CALL dlamrg( n1, n2, d, 1, -1, idxq )
*
      RETURN
*
*     End of DLASD6
*

dlasd7()

subroutine dlasd7	(	integer	icompq,
		integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		double precision, dimension( * )	d,
		double precision, dimension( * )	z,
		double precision, dimension( * )	zw,
		double precision, dimension( * )	vf,
		double precision, dimension( * )	vfw,
		double precision, dimension( * )	vl,
		double precision, dimension( * )	vlw,
		double precision	alpha,
		double precision	beta,
		double precision, dimension( * )	dsigma,
		integer, dimension( * )	idx,
		integer, dimension( * )	idxp,
		integer, dimension( * )	idxq,
		integer, dimension( * )	perm,
		integer	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		double precision, dimension( ldgnum, * )	givnum,
		integer	ldgnum,
		double precision	c,
		double precision	s,
		integer	info )

DLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc.

Download DLASD7 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD7 merges the two sets of singular values 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 singular
!> values 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.
!>
!> DLASD7 is called from DLASD6.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed !> in compact form, as follows: !> = 0: Compute singular values only. !> = 1: Compute singular vectors of upper !> bidiagonal matrix in compact form. !>
[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has !> N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, this is !> the order of the related secular equation. 1 <= K <=N. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension ( N ) !> On entry D contains the singular values of the two submatrices !> to be combined. On exit D contains the trailing (N-K) updated !> singular values (those which were deflated) sorted into !> increasing order. !>
[out]	Z	!> Z is DOUBLE PRECISION array, dimension ( M ) !> On exit Z contains the updating row vector in the secular !> equation. !>
[out]	ZW	!> ZW is DOUBLE PRECISION array, dimension ( M ) !> Workspace for Z. !>
[in,out]	VF	!> VF is DOUBLE PRECISION array, dimension ( M ) !> On entry, VF(1:NL+1) contains the first components of all !> right singular vectors of the upper block; and VF(NL+2:M) !> contains the first components of all right singular vectors !> of the lower block. On exit, VF contains the first components !> of all right singular vectors of the bidiagonal matrix. !>
[out]	VFW	!> VFW is DOUBLE PRECISION array, dimension ( M ) !> Workspace for VF. !>
[in,out]	VL	!> VL is DOUBLE PRECISION array, dimension ( M ) !> On entry, VL(1:NL+1) contains the last components of all !> right singular vectors of the upper block; and VL(NL+2:M) !> contains the last components of all right singular vectors !> of the lower block. On exit, VL contains the last components !> of all right singular vectors of the bidiagonal matrix. !>
[out]	VLW	!> VLW is DOUBLE PRECISION array, dimension ( M ) !> Workspace for VL. !>
[in]	ALPHA	!> ALPHA is DOUBLE PRECISION !> Contains the diagonal element associated with the added row. !>
[in]	BETA	!> BETA is DOUBLE PRECISION !> Contains the off-diagonal element associated with the added !> row. !>
[out]	DSIGMA	!> DSIGMA is DOUBLE PRECISION array, dimension ( N ) !> Contains a copy of the diagonal elements (K-1 singular values !> and one zero) in the secular equation. !>
[out]	IDX	!> IDX is INTEGER array, dimension ( N ) !> This will contain the permutation used to sort the contents of !> D into ascending order. !>
[out]	IDXP	!> IDXP is INTEGER array, dimension ( N ) !> This will contain the permutation used to place deflated !> values of D at the end of the array. On output IDXP(2:K) !> points to the nondeflated D-values and IDXP(K+1:N) !> points to the deflated singular values. !>
[in]	IDXQ	!> IDXQ is INTEGER array, dimension ( N ) !> This contains the permutation which separately sorts the two !> sub-problems in D into ascending order. Note that entries in !> the first half of this permutation must first be moved one !> position backward; and entries in the second half !> must first have NL+1 added to their values. !>
[out]	PERM	!> PERM is INTEGER array, dimension ( N ) !> The permutations (from deflation and sorting) to be applied !> to each singular block. Not referenced if ICOMPQ = 0. !>
[out]	GIVPTR	!> GIVPTR is INTEGER !> The number of Givens rotations which took place in this !> subproblem. Not referenced if ICOMPQ = 0. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGCOL	!> LDGCOL is INTEGER !> The leading dimension of GIVCOL, must be at least N. !>
[out]	GIVNUM	!> GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) !> Each number indicates the C or S value to be used in the !> corresponding Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGNUM	!> LDGNUM is INTEGER !> The leading dimension of GIVNUM, must be at least N. !>
[out]	C	!> C is DOUBLE PRECISION !> C contains garbage if SQRE =0 and the C-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	S	!> S is DOUBLE PRECISION !> S contains garbage if SQRE =0 and the S-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 276 of file dlasd7.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
     $                   NR, SQRE
      DOUBLE PRECISION   ALPHA, BETA, C, S
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
     $                   IDXQ( * ), PERM( * )
      DOUBLE PRECISION   D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
     $                   VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
     $                   ZW( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, EIGHT
      parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
     $                   eight = 8.0d+0 )
*     ..
*     .. Local Scalars ..
*
      INTEGER            I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
     $                   NLP1, NLP2
      DOUBLE PRECISION   EPS, HLFTOL, TAU, TOL, Z1
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlamrg, drot, xerbla
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           dlamch, dlapy2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      n = nl + nr + 1
      m = n + sqre
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( nl.LT.1 ) THEN
         info = -2
      ELSE IF( nr.LT.1 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldgcol.LT.n ) THEN
         info = -22
      ELSE IF( ldgnum.LT.n ) THEN
         info = -24
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD7', -info )
         RETURN
      END IF
*
      nlp1 = nl + 1
      nlp2 = nl + 2
      IF( icompq.EQ.1 ) THEN
         givptr = 0
      END IF
*
*     Generate the first part of the vector Z and move the singular
*     values in the first part of D one position backward.
*
      z1 = alpha*vl( nlp1 )
      vl( nlp1 ) = zero
      tau = vf( nlp1 )
      DO 10 i = nl, 1, -1
         z( i+1 ) = alpha*vl( i )
         vl( i ) = zero
         vf( i+1 ) = vf( i )
         d( i+1 ) = d( i )
         idxq( i+1 ) = idxq( i ) + 1
   10 CONTINUE
      vf( 1 ) = tau
*
*     Generate the second part of the vector Z.
*
      DO 20 i = nlp2, m
         z( i ) = beta*vf( i )
         vf( i ) = zero
   20 CONTINUE
*
*     Sort the singular values into increasing order
*
      DO 30 i = nlp2, n
         idxq( i ) = idxq( i ) + nlp1
   30 CONTINUE
*
*     DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
      DO 40 i = 2, n
         dsigma( i ) = d( idxq( i ) )
         zw( i ) = z( idxq( i ) )
         vfw( i ) = vf( idxq( i ) )
         vlw( i ) = vl( idxq( i ) )
   40 CONTINUE
*
      CALL dlamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
*
      DO 50 i = 2, n
         idxi = 1 + idx( i )
         d( i ) = dsigma( idxi )
         z( i ) = zw( idxi )
         vf( i ) = vfw( idxi )
         vl( i ) = vlw( idxi )
   50 CONTINUE
*
*     Calculate the allowable deflation tolerance
*
      eps = dlamch( 'Epsilon' )
      tol = max( abs( alpha ), abs( beta ) )
      tol = eight*eight*eps*max( abs( d( n ) ), tol )
*
*     There are 2 kinds of deflation -- first a value in the z-vector
*     is small, second two (or more) singular values are very close
*     together (their difference is small).
*
*     If the value in the z-vector is small, we simply permute the
*     array so that the corresponding singular value is moved to the
*     end.
*
*     If two values in the D-vector are close, we perform a two-sided
*     rotation designed to make one of the corresponding z-vector
*     entries zero, and then permute the array so that the deflated
*     singular value is moved to the end.
*
*     If there are multiple singular values then the problem deflates.
*     Here the number of equal singular values are found.  As each equal
*     singular value is found, an elementary reflector is computed to
*     rotate the corresponding singular subspace so that the
*     corresponding components of Z are zero in this new basis.
*
      k = 1
      k2 = n + 1
      DO 60 j = 2, n
         IF( abs( z( j ) ).LE.tol ) THEN
*
*           Deflate due to small z component.
*
            k2 = k2 - 1
            idxp( k2 ) = j
            IF( j.EQ.n )
     $         GO TO 100
         ELSE
            jprev = j
            GO TO 70
         END IF
   60 CONTINUE
   70 CONTINUE
      j = jprev
   80 CONTINUE
      j = j + 1
      IF( j.GT.n )
     $   GO TO 90
      IF( abs( z( j ) ).LE.tol ) THEN
*
*        Deflate due to small z component.
*
         k2 = k2 - 1
         idxp( k2 ) = j
      ELSE
*
*        Check if singular values are close enough to allow deflation.
*
         IF( abs( d( j )-d( jprev ) ).LE.tol ) THEN
*
*           Deflation is possible.
*
            s = z( jprev )
            c = z( j )
*
*           Find sqrt(a**2+b**2) without overflow or
*           destructive underflow.
*
            tau = dlapy2( c, s )
            z( j ) = tau
            z( jprev ) = zero
            c = c / tau
            s = -s / tau
*
*           Record the appropriate Givens rotation
*
            IF( icompq.EQ.1 ) THEN
               givptr = givptr + 1
               idxjp = idxq( idx( jprev )+1 )
               idxj = idxq( idx( j )+1 )
               IF( idxjp.LE.nlp1 ) THEN
                  idxjp = idxjp - 1
               END IF
               IF( idxj.LE.nlp1 ) THEN
                  idxj = idxj - 1
               END IF
               givcol( givptr, 2 ) = idxjp
               givcol( givptr, 1 ) = idxj
               givnum( givptr, 2 ) = c
               givnum( givptr, 1 ) = s
            END IF
            CALL drot( 1, vf( jprev ), 1, vf( j ), 1, c, s )
            CALL drot( 1, vl( jprev ), 1, vl( j ), 1, c, s )
            k2 = k2 - 1
            idxp( k2 ) = jprev
            jprev = j
         ELSE
            k = k + 1
            zw( k ) = z( jprev )
            dsigma( k ) = d( jprev )
            idxp( k ) = jprev
            jprev = j
         END IF
      END IF
      GO TO 80
   90 CONTINUE
*
*     Record the last singular value.
*
      k = k + 1
      zw( k ) = z( jprev )
      dsigma( k ) = d( jprev )
      idxp( k ) = jprev
*
  100 CONTINUE
*
*     Sort the singular values into DSIGMA. The singular values which
*     were not deflated go into the first K slots of DSIGMA, except
*     that DSIGMA(1) is treated separately.
*
      DO 110 j = 2, n
         jp = idxp( j )
         dsigma( j ) = d( jp )
         vfw( j ) = vf( jp )
         vlw( j ) = vl( jp )
  110 CONTINUE
      IF( icompq.EQ.1 ) THEN
         DO 120 j = 2, n
            jp = idxp( j )
            perm( j ) = idxq( idx( jp )+1 )
            IF( perm( j ).LE.nlp1 ) THEN
               perm( j ) = perm( j ) - 1
            END IF
  120    CONTINUE
      END IF
*
*     The deflated singular values go back into the last N - K slots of
*     D.
*
      CALL dcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
*
*     Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
*     VL(M).
*
      dsigma( 1 ) = zero
      hlftol = tol / two
      IF( abs( dsigma( 2 ) ).LE.hlftol )
     $   dsigma( 2 ) = hlftol
      IF( m.GT.n ) THEN
         z( 1 ) = dlapy2( z1, z( m ) )
         IF( z( 1 ).LE.tol ) THEN
            c = one
            s = zero
            z( 1 ) = tol
         ELSE
            c = z1 / z( 1 )
            s = -z( m ) / z( 1 )
         END IF
         CALL drot( 1, vf( m ), 1, vf( 1 ), 1, c, s )
         CALL drot( 1, vl( m ), 1, vl( 1 ), 1, c, s )
      ELSE
         IF( abs( z1 ).LE.tol ) THEN
            z( 1 ) = tol
         ELSE
            z( 1 ) = z1
         END IF
      END IF
*
*     Restore Z, VF, and VL.
*
      CALL dcopy( k-1, zw( 2 ), 1, z( 2 ), 1 )
      CALL dcopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 )
      CALL dcopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 )
*
      RETURN
*
*     End of DLASD7
*

dlasd8()

subroutine dlasd8	(	integer	icompq,
		integer	k,
		double precision, dimension( * )	d,
		double precision, dimension( * )	z,
		double precision, dimension( * )	vf,
		double precision, dimension( * )	vl,
		double precision, dimension( * )	difl,
		double precision, dimension( lddifr, * )	difr,
		integer	lddifr,
		double precision, dimension( * )	dsigma,
		double precision, dimension( * )	work,
		integer	info )

DLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc.

Download DLASD8 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASD8 finds the square roots of the roots of the secular equation,
!> as defined by the values in DSIGMA and Z. It makes the appropriate
!> calls to DLASD4, and stores, for each  element in D, the distance
!> to its two nearest poles (elements in DSIGMA). It also updates
!> the arrays VF and VL, the first and last components of all the
!> right singular vectors of the original bidiagonal matrix.
!>
!> DLASD8 is called from DLASD6.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed in !> factored form in the calling routine: !> = 0: Compute singular values only. !> = 1: Compute singular vectors in factored form as well. !>
[in]	K	!> K is INTEGER !> The number of terms in the rational function to be solved !> by DLASD4. K >= 1. !>
[out]	D	!> D is DOUBLE PRECISION array, dimension ( K ) !> On output, D contains the updated singular values. !>
[in,out]	Z	!> Z is DOUBLE PRECISION array, dimension ( K ) !> On entry, the first K elements of this array contain the !> components of the deflation-adjusted updating row vector. !> On exit, Z is updated. !>
[in,out]	VF	!> VF is DOUBLE PRECISION array, dimension ( K ) !> On entry, VF contains information passed through DBEDE8. !> On exit, VF contains the first K components of the first !> components of all right singular vectors of the bidiagonal !> matrix. !>
[in,out]	VL	!> VL is DOUBLE PRECISION array, dimension ( K ) !> On entry, VL contains information passed through DBEDE8. !> On exit, VL contains the first K components of the last !> components of all right singular vectors of the bidiagonal !> matrix. !>
[out]	DIFL	!> DIFL is DOUBLE PRECISION array, dimension ( K ) !> On exit, DIFL(I) = D(I) - DSIGMA(I). !>
[out]	DIFR	!> DIFR is DOUBLE PRECISION array, !> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and !> dimension ( K ) if ICOMPQ = 0. !> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not !> defined and will not be referenced. !> !> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the !> normalizing factors for the right singular vector matrix. !>
[in]	LDDIFR	!> LDDIFR is INTEGER !> The leading dimension of DIFR, must be at least K. !>
[in,out]	DSIGMA	!> DSIGMA is DOUBLE PRECISION array, dimension ( K ) !> On entry, the first K elements of this array contain the old !> roots of the deflated updating problem. These are the poles !> of the secular equation. !> On exit, the elements of DSIGMA may be very slightly altered !> in value. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (3*K) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 164 of file dlasd8.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, K, LDDIFR
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), DIFL( * ), DIFR( LDDIFR, * ),
     $                   DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
      DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlascl, dlasd4, dlaset, xerbla
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DDOT, DLAMC3, DNRM2
      EXTERNAL           ddot, dlamc3, dnrm2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( k.LT.1 ) THEN
         info = -2
      ELSE IF( lddifr.LT.k ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASD8', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( k.EQ.1 ) THEN
         d( 1 ) = abs( z( 1 ) )
         difl( 1 ) = d( 1 )
         IF( icompq.EQ.1 ) THEN
            difl( 2 ) = one
            difr( 1, 2 ) = one
         END IF
         RETURN
      END IF
*
*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
*     which on any of these machines zeros out the bottommost
*     bit of DSIGMA(I) if it is 1; this makes the subsequent
*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
*     occurs. On binary machines with a guard digit (almost all
*     machines) it does not change DSIGMA(I) at all. On hexadecimal
*     and decimal machines with a guard digit, it slightly
*     changes the bottommost bits of DSIGMA(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 10 i = 1, k
         dsigma( i ) = dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
   10 CONTINUE
*
*     Book keeping.
*
      iwk1 = 1
      iwk2 = iwk1 + k
      iwk3 = iwk2 + k
      iwk2i = iwk2 - 1
      iwk3i = iwk3 - 1
*
*     Normalize Z.
*
      rho = dnrm2( k, z, 1 )
      CALL dlascl( 'G', 0, 0, rho, one, k, 1, z, k, info )
      rho = rho*rho
*
*     Initialize WORK(IWK3).
*
      CALL dlaset( 'A', k, 1, one, one, work( iwk3 ), k )
*
*     Compute the updated singular values, the arrays DIFL, DIFR,
*     and the updated Z.
*
      DO 40 j = 1, k
         CALL dlasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ),
     $                work( iwk2 ), info )
*
*        If the root finder fails, report the convergence failure.
*
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         work( iwk3i+j ) = work( iwk3i+j )*work( j )*work( iwk2i+j )
         difl( j ) = -work( j )
         difr( j, 1 ) = -work( j+1 )
         DO 20 i = 1, j - 1
            work( iwk3i+i ) = work( iwk3i+i )*work( i )*
     $                        work( iwk2i+i ) / ( dsigma( i )-
     $                        dsigma( j ) ) / ( dsigma( i )+
     $                        dsigma( j ) )
   20    CONTINUE
         DO 30 i = j + 1, k
            work( iwk3i+i ) = work( iwk3i+i )*work( i )*
     $                        work( iwk2i+i ) / ( dsigma( i )-
     $                        dsigma( j ) ) / ( dsigma( i )+
     $                        dsigma( j ) )
   30    CONTINUE
   40 CONTINUE
*
*     Compute updated Z.
*
      DO 50 i = 1, k
         z( i ) = sign( sqrt( abs( work( iwk3i+i ) ) ), z( i ) )
   50 CONTINUE
*
*     Update VF and VL.
*
      DO 80 j = 1, k
         diflj = difl( j )
         dj = d( j )
         dsigj = -dsigma( j )
         IF( j.LT.k ) THEN
            difrj = -difr( j, 1 )
            dsigjp = -dsigma( j+1 )
         END IF
         work( j ) = -z( j ) / diflj / ( dsigma( j )+dj )
         DO 60 i = 1, j - 1
            work( i ) = z( i ) / ( dlamc3( dsigma( i ), dsigj )-diflj )
     $                   / ( dsigma( i )+dj )
   60    CONTINUE
         DO 70 i = j + 1, k
            work( i ) = z( i ) / ( dlamc3( dsigma( i ), dsigjp )+difrj )
     $                   / ( dsigma( i )+dj )
   70    CONTINUE
         temp = dnrm2( k, work, 1 )
         work( iwk2i+j ) = ddot( k, work, 1, vf, 1 ) / temp
         work( iwk3i+j ) = ddot( k, work, 1, vl, 1 ) / temp
         IF( icompq.EQ.1 ) THEN
            difr( j, 2 ) = temp
         END IF
   80 CONTINUE
*
      CALL dcopy( k, work( iwk2 ), 1, vf, 1 )
      CALL dcopy( k, work( iwk3 ), 1, vl, 1 )
*
      RETURN
*
*     End of DLASD8
*

dlasda()

subroutine dlasda	(	integer	icompq,
		integer	smlsiz,
		integer	n,
		integer	sqre,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldu, * )	vt,
		integer, dimension( * )	k,
		double precision, dimension( ldu, * )	difl,
		double precision, dimension( ldu, * )	difr,
		double precision, dimension( ldu, * )	z,
		double precision, dimension( ldu, * )	poles,
		integer, dimension( * )	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		integer, dimension( ldgcol, * )	perm,
		double precision, dimension( ldu, * )	givnum,
		double precision, dimension( * )	c,
		double precision, dimension( * )	s,
		double precision, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

DLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.

Download DLASDA + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Using a divide and conquer approach, DLASDA computes the singular
!> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
!> B with diagonal D and offdiagonal E, where M = N + SQRE. The
!> algorithm computes the singular values in the SVD B = U * S * VT.
!> The orthogonal matrices U and VT are optionally computed in
!> compact form.
!>
!> A related subroutine, DLASD0, computes the singular values and
!> the singular vectors in explicit form.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed !> in compact form, as follows !> = 0: Compute singular values only. !> = 1: Compute singular vectors of upper bidiagonal !> matrix in compact form. !>
[in]	SMLSIZ	!> SMLSIZ is INTEGER !> The maximum size of the subproblems at the bottom of the !> computation tree. !>
[in]	N	!> N is INTEGER !> The row dimension of the upper bidiagonal matrix. This is !> also the dimension of the main diagonal array D. !>
[in]	SQRE	!> SQRE is INTEGER !> Specifies the column dimension of the bidiagonal matrix. !> = 0: The bidiagonal matrix has column dimension M = N; !> = 1: The bidiagonal matrix has column dimension M = N + 1. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension ( N ) !> On entry D contains the main diagonal of the bidiagonal !> matrix. On exit D, if INFO = 0, contains its singular values. !>
[in]	E	!> E is DOUBLE PRECISION array, dimension ( M-1 ) !> Contains the subdiagonal entries of the bidiagonal matrix. !> On exit, E has been destroyed. !>
[out]	U	!> U is DOUBLE PRECISION array, !> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left !> singular vector matrices of all subproblems at the bottom !> level. !>
[in]	LDU	!> LDU is INTEGER, LDU = > N. !> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, !> GIVNUM, and Z. !>
[out]	VT	!> VT is DOUBLE PRECISION array, !> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right !> singular vector matrices of all subproblems at the bottom !> level. !>
[out]	K	!> K is INTEGER array, !> dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. !> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th !> secular equation on the computation tree. !>
[out]	DIFL	!> DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ), !> where NLVL = floor(log_2 (N/SMLSIZ))). !>
[out]	DIFR	!> DIFR is DOUBLE PRECISION array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and !> dimension ( N ) if ICOMPQ = 0. !> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) !> record distances between singular values on the I-th !> level and singular values on the (I -1)-th level, and !> DIFR(1:N, 2 * I ) contains the normalizing factors for !> the right singular vector matrix. See DLASD8 for details. !>
[out]	Z	!> Z is DOUBLE PRECISION array, !> dimension ( LDU, NLVL ) if ICOMPQ = 1 and !> dimension ( N ) if ICOMPQ = 0. !> The first K elements of Z(1, I) contain the components of !> the deflation-adjusted updating row vector for subproblems !> on the I-th level. !>
[out]	POLES	!> POLES is DOUBLE PRECISION array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and !> POLES(1, 2*I) contain the new and old singular values !> involved in the secular equations on the I-th level. !>
[out]	GIVPTR	!> GIVPTR is INTEGER array, !> dimension ( N ) if ICOMPQ = 1, and not referenced if !> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records !> the number of Givens rotations performed on the I-th !> problem on the computation tree. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, !> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not !> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, !> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations !> of Givens rotations performed on the I-th level on the !> computation tree. !>
[in]	LDGCOL	!> LDGCOL is INTEGER, LDGCOL = > N. !> The leading dimension of arrays GIVCOL and PERM. !>
[out]	PERM	!> PERM is INTEGER array, !> dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records !> permutations done on the I-th level of the computation tree. !>
[out]	GIVNUM	!> GIVNUM is DOUBLE PRECISION array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not !> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, !> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- !> values of Givens rotations performed on the I-th level on !> the computation tree. !>
[out]	C	!> C is DOUBLE PRECISION array, !> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. !> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, !> C( I ) contains the C-value of a Givens rotation related to !> the right null space of the I-th subproblem. !>
[out]	S	!> S is DOUBLE PRECISION array, dimension ( N ) if !> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 !> and the I-th subproblem is not square, on exit, S( I ) !> contains the S-value of a Givens rotation related to !> the right null space of the I-th subproblem. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension !> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (7*N) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 270 of file dlasda.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
     $                   K( * ), PERM( LDGCOL, * )
      DOUBLE PRECISION   C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
     $                   E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
     $                   S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
     $                   Z( LDU, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d+0, one = 1.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
     $                   J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
     $                   NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. External Subroutines ..
      EXTERNAL           dcopy, dlasd6, dlasdq, dlasdt, dlaset, xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( smlsiz.LT.3 ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldu.LT.( n+sqre ) ) THEN
         info = -8
      ELSE IF( ldgcol.LT.n ) THEN
         info = -17
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASDA', -info )
         RETURN
      END IF
*
      m = n + sqre
*
*     If the input matrix is too small, call DLASDQ to find the SVD.
*
      IF( n.LE.smlsiz ) THEN
         IF( icompq.EQ.0 ) THEN
            CALL dlasdq( 'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu,
     $                   u, ldu, work, info )
         ELSE
            CALL dlasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu,
     $                   u, ldu, work, info )
         END IF
         RETURN
      END IF
*
*     Book-keeping and  set up the computation tree.
*
      inode = 1
      ndiml = inode + n
      ndimr = ndiml + n
      idxq = ndimr + n
      iwk = idxq + n
*
      ncc = 0
      nru = 0
*
      smlszp = smlsiz + 1
      vf = 1
      vl = vf + m
      nwork1 = vl + m
      nwork2 = nwork1 + smlszp*smlszp
*
      CALL dlasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
     $             iwork( ndimr ), smlsiz )
*
*     for the nodes on bottom level of the tree, solve
*     their subproblems by DLASDQ.
*
      ndb1 = ( nd+1 ) / 2
      DO 30 i = ndb1, nd
*
*        IC : center row of each node
*        NL : number of rows of left  subproblem
*        NR : number of rows of right subproblem
*        NLF: starting row of the left   subproblem
*        NRF: starting row of the right  subproblem
*
         i1 = i - 1
         ic = iwork( inode+i1 )
         nl = iwork( ndiml+i1 )
         nlp1 = nl + 1
         nr = iwork( ndimr+i1 )
         nlf = ic - nl
         nrf = ic + 1
         idxqi = idxq + nlf - 2
         vfi = vf + nlf - 1
         vli = vl + nlf - 1
         sqrei = 1
         IF( icompq.EQ.0 ) THEN
            CALL dlaset( 'A', nlp1, nlp1, zero, one, work( nwork1 ),
     $                   smlszp )
            CALL dlasdq( 'U', sqrei, nl, nlp1, nru, ncc, d( nlf ),
     $                   e( nlf ), work( nwork1 ), smlszp,
     $                   work( nwork2 ), nl, work( nwork2 ), nl,
     $                   work( nwork2 ), info )
            itemp = nwork1 + nl*smlszp
            CALL dcopy( nlp1, work( nwork1 ), 1, work( vfi ), 1 )
            CALL dcopy( nlp1, work( itemp ), 1, work( vli ), 1 )
         ELSE
            CALL dlaset( 'A', nl, nl, zero, one, u( nlf, 1 ), ldu )
            CALL dlaset( 'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu )
            CALL dlasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ),
     $                   e( nlf ), vt( nlf, 1 ), ldu, u( nlf, 1 ), ldu,
     $                   u( nlf, 1 ), ldu, work( nwork1 ), info )
            CALL dcopy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 )
            CALL dcopy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 )
         END IF
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         DO 10 j = 1, nl
            iwork( idxqi+j ) = j
   10    CONTINUE
         IF( ( i.EQ.nd ) .AND. ( sqre.EQ.0 ) ) THEN
            sqrei = 0
         ELSE
            sqrei = 1
         END IF
         idxqi = idxqi + nlp1
         vfi = vfi + nlp1
         vli = vli + nlp1
         nrp1 = nr + sqrei
         IF( icompq.EQ.0 ) THEN
            CALL dlaset( 'A', nrp1, nrp1, zero, one, work( nwork1 ),
     $                   smlszp )
            CALL dlasdq( 'U', sqrei, nr, nrp1, nru, ncc, d( nrf ),
     $                   e( nrf ), work( nwork1 ), smlszp,
     $                   work( nwork2 ), nr, work( nwork2 ), nr,
     $                   work( nwork2 ), info )
            itemp = nwork1 + ( nrp1-1 )*smlszp
            CALL dcopy( nrp1, work( nwork1 ), 1, work( vfi ), 1 )
            CALL dcopy( nrp1, work( itemp ), 1, work( vli ), 1 )
         ELSE
            CALL dlaset( 'A', nr, nr, zero, one, u( nrf, 1 ), ldu )
            CALL dlaset( 'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu )
            CALL dlasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ),
     $                   e( nrf ), vt( nrf, 1 ), ldu, u( nrf, 1 ), ldu,
     $                   u( nrf, 1 ), ldu, work( nwork1 ), info )
            CALL dcopy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 )
            CALL dcopy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 )
         END IF
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         DO 20 j = 1, nr
            iwork( idxqi+j ) = j
   20    CONTINUE
   30 CONTINUE
*
*     Now conquer each subproblem bottom-up.
*
      j = 2**nlvl
      DO 50 lvl = nlvl, 1, -1
         lvl2 = lvl*2 - 1
*
*        Find the first node LF and last node LL on
*        the current level LVL.
*
         IF( lvl.EQ.1 ) THEN
            lf = 1
            ll = 1
         ELSE
            lf = 2**( lvl-1 )
            ll = 2*lf - 1
         END IF
         DO 40 i = lf, ll
            im1 = i - 1
            ic = iwork( inode+im1 )
            nl = iwork( ndiml+im1 )
            nr = iwork( ndimr+im1 )
            nlf = ic - nl
            nrf = ic + 1
            IF( i.EQ.ll ) THEN
               sqrei = sqre
            ELSE
               sqrei = 1
            END IF
            vfi = vf + nlf - 1
            vli = vl + nlf - 1
            idxqi = idxq + nlf - 1
            alpha = d( ic )
            beta = e( ic )
            IF( icompq.EQ.0 ) THEN
               CALL dlasd6( icompq, nl, nr, sqrei, d( nlf ),
     $                      work( vfi ), work( vli ), alpha, beta,
     $                      iwork( idxqi ), perm, givptr( 1 ), givcol,
     $                      ldgcol, givnum, ldu, poles, difl, difr, z,
     $                      k( 1 ), c( 1 ), s( 1 ), work( nwork1 ),
     $                      iwork( iwk ), info )
            ELSE
               j = j - 1
               CALL dlasd6( icompq, nl, nr, sqrei, d( nlf ),
     $                      work( vfi ), work( vli ), alpha, beta,
     $                      iwork( idxqi ), perm( nlf, lvl ),
     $                      givptr( j ), givcol( nlf, lvl2 ), ldgcol,
     $                      givnum( nlf, lvl2 ), ldu,
     $                      poles( nlf, lvl2 ), difl( nlf, lvl ),
     $                      difr( nlf, lvl2 ), z( nlf, lvl ), k( j ),
     $                      c( j ), s( j ), work( nwork1 ),
     $                      iwork( iwk ), info )
            END IF
            IF( info.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of DLASDA
*

dlasdq()

subroutine dlasdq	(	character	uplo,
		integer	sqre,
		integer	n,
		integer	ncvt,
		integer	nru,
		integer	ncc,
		double precision, dimension( * )	d,
		double precision, dimension( * )	e,
		double precision, dimension( ldvt, * )	vt,
		integer	ldvt,
		double precision, dimension( ldu, * )	u,
		integer	ldu,
		double precision, dimension( ldc, * )	c,
		integer	ldc,
		double precision, dimension( * )	work,
		integer	info )

DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.

Download DLASDQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASDQ computes the singular value decomposition (SVD) of a real
!> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
!> E, accumulating the transformations if desired. Letting B denote
!> the input bidiagonal matrix, the algorithm computes orthogonal
!> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose
!> of P). The singular values S are overwritten on D.
!>
!> The input matrix U  is changed to U  * Q  if desired.
!> The input matrix VT is changed to P**T * VT if desired.
!> The input matrix C  is changed to Q**T * C  if desired.
!>
!> See  by J. Demmel and W. Kahan,
!> LAPACK Working Note #3, for a detailed description of the algorithm.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the input bidiagonal matrix !> is upper or lower bidiagonal, and whether it is square are !> not. !> UPLO = 'U' or 'u' B is upper bidiagonal. !> UPLO = 'L' or 'l' B is lower bidiagonal. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: then the input matrix is N-by-N. !> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and !> (N+1)-by-N if UPLU = 'L'. !> !> The bidiagonal matrix has !> N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[in]	N	!> N is INTEGER !> On entry, N specifies the number of rows and columns !> in the matrix. N must be at least 0. !>
[in]	NCVT	!> NCVT is INTEGER !> On entry, NCVT specifies the number of columns of !> the matrix VT. NCVT must be at least 0. !>
[in]	NRU	!> NRU is INTEGER !> On entry, NRU specifies the number of rows of !> the matrix U. NRU must be at least 0. !>
[in]	NCC	!> NCC is INTEGER !> On entry, NCC specifies the number of columns of !> the matrix C. NCC must be at least 0. !>
[in,out]	D	!> D is DOUBLE PRECISION array, dimension (N) !> On entry, D contains the diagonal entries of the !> bidiagonal matrix whose SVD is desired. On normal exit, !> D contains the singular values in ascending order. !>
[in,out]	E	!> E is DOUBLE PRECISION array. !> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. !> On entry, the entries of E contain the offdiagonal entries !> of the bidiagonal matrix whose SVD is desired. On normal !> exit, E will contain 0. If the algorithm does not converge, !> D and E will contain the diagonal and superdiagonal entries !> of a bidiagonal matrix orthogonally equivalent to the one !> given as input. !>
[in,out]	VT	!> VT is DOUBLE PRECISION array, dimension (LDVT, NCVT) !> On entry, contains a matrix which on exit has been !> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 !> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). !>
[in]	LDVT	!> LDVT is INTEGER !> On entry, LDVT specifies the leading dimension of VT as !> declared in the calling (sub) program. LDVT must be at !> least 1. If NCVT is nonzero LDVT must also be at least N. !>
[in,out]	U	!> U is DOUBLE PRECISION array, dimension (LDU, N) !> On entry, contains a matrix which on exit has been !> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 !> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). !>
[in]	LDU	!> LDU is INTEGER !> On entry, LDU specifies the leading dimension of U as !> declared in the calling (sub) program. LDU must be at !> least max( 1, NRU ) . !>
[in,out]	C	!> C is DOUBLE PRECISION array, dimension (LDC, NCC) !> On entry, contains an N-by-NCC matrix which on exit !> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 !> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). !>
[in]	LDC	!> LDC is INTEGER !> On entry, LDC specifies the leading dimension of C as !> declared in the calling (sub) program. LDC must be at !> least 1. If NCC is nonzero, LDC must also be at least N. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (4*N) !> Workspace. Only referenced if one of NCVT, NRU, or NCC is !> nonzero, and if N is at least 2. !>
[out]	INFO	!> INFO is INTEGER !> On exit, a value of 0 indicates a successful exit. !> If INFO < 0, argument number -INFO is illegal. !> If INFO > 0, the algorithm did not converge, and INFO !> specifies how many superdiagonals did not converge. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 209 of file dlasdq.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
      DOUBLE PRECISION   CS, R, SMIN, SN
*     ..
*     .. External Subroutines ..
      EXTERNAL           dbdsqr, dlartg, dlasr, dswap, xerbla
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      iuplo = 0
      IF( lsame( uplo, 'U' ) )
     $   iuplo = 1
      IF( lsame( uplo, 'L' ) )
     $   iuplo = 2
      IF( iuplo.EQ.0 ) THEN
         info = -1
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( ncvt.LT.0 ) THEN
         info = -4
      ELSE IF( nru.LT.0 ) THEN
         info = -5
      ELSE IF( ncc.LT.0 ) THEN
         info = -6
      ELSE IF( ( ncvt.EQ.0 .AND. ldvt.LT.1 ) .OR.
     $         ( ncvt.GT.0 .AND. ldvt.LT.max( 1, n ) ) ) THEN
         info = -10
      ELSE IF( ldu.LT.max( 1, nru ) ) THEN
         info = -12
      ELSE IF( ( ncc.EQ.0 .AND. ldc.LT.1 ) .OR.
     $         ( ncc.GT.0 .AND. ldc.LT.max( 1, n ) ) ) THEN
         info = -14
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASDQ', -info )
         RETURN
      END IF
      IF( n.EQ.0 )
     $   RETURN
*
*     ROTATE is true if any singular vectors desired, false otherwise
*
      rotate = ( ncvt.GT.0 ) .OR. ( nru.GT.0 ) .OR. ( ncc.GT.0 )
      np1 = n + 1
      sqre1 = sqre
*
*     If matrix non-square upper bidiagonal, rotate to be lower
*     bidiagonal.  The rotations are on the right.
*
      IF( ( iuplo.EQ.1 ) .AND. ( sqre1.EQ.1 ) ) THEN
         DO 10 i = 1, n - 1
            CALL dlartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   10    CONTINUE
         CALL dlartg( d( n ), e( n ), cs, sn, r )
         d( n ) = r
         e( n ) = zero
         IF( rotate ) THEN
            work( n ) = cs
            work( n+n ) = sn
         END IF
         iuplo = 2
         sqre1 = 0
*
*        Update singular vectors if desired.
*
         IF( ncvt.GT.0 )
     $      CALL dlasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),
     $                  work( np1 ), vt, ldvt )
      END IF
*
*     If matrix lower bidiagonal, rotate to be upper bidiagonal
*     by applying Givens rotations on the left.
*
      IF( iuplo.EQ.2 ) THEN
         DO 20 i = 1, n - 1
            CALL dlartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   20    CONTINUE
*
*        If matrix (N+1)-by-N lower bidiagonal, one additional
*        rotation is needed.
*
         IF( sqre1.EQ.1 ) THEN
            CALL dlartg( d( n ), e( n ), cs, sn, r )
            d( n ) = r
            IF( rotate ) THEN
               work( n ) = cs
               work( n+n ) = sn
            END IF
         END IF
*
*        Update singular vectors if desired.
*
         IF( nru.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL dlasr( 'R', 'V', 'F', nru, n, work( 1 ),
     $                     work( np1 ), u, ldu )
            ELSE
               CALL dlasr( 'R', 'V', 'F', nru, np1, work( 1 ),
     $                     work( np1 ), u, ldu )
            END IF
         END IF
         IF( ncc.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL dlasr( 'L', 'V', 'F', n, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            ELSE
               CALL dlasr( 'L', 'V', 'F', np1, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            END IF
         END IF
      END IF
*
*     Call DBDSQR to compute the SVD of the reduced real
*     N-by-N upper bidiagonal matrix.
*
      CALL dbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,
     $             ldc, work, info )
*
*     Sort the singular values into ascending order (insertion sort on
*     singular values, but only one transposition per singular vector)
*
      DO 40 i = 1, n
*
*        Scan for smallest D(I).
*
         isub = i
         smin = d( i )
         DO 30 j = i + 1, n
            IF( d( j ).LT.smin ) THEN
               isub = j
               smin = d( j )
            END IF
   30    CONTINUE
         IF( isub.NE.i ) THEN
*
*           Swap singular values and vectors.
*
            d( isub ) = d( i )
            d( i ) = smin
            IF( ncvt.GT.0 )
     $         CALL dswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt )
            IF( nru.GT.0 )
     $         CALL dswap( nru, u( 1, isub ), 1, u( 1, i ), 1 )
            IF( ncc.GT.0 )
     $         CALL dswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc )
         END IF
   40 CONTINUE
*
      RETURN
*
*     End of DLASDQ
*

dlasdt()

subroutine dlasdt	(	integer	n,
		integer	lvl,
		integer	nd,
		integer, dimension( * )	inode,
		integer, dimension( * )	ndiml,
		integer, dimension( * )	ndimr,
		integer	msub )

DLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.

Download DLASDT + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASDT creates a tree of subproblems for bidiagonal divide and
!> conquer.
!> 

Parameters

[in]	N	!> N is INTEGER !> On entry, the number of diagonal elements of the !> bidiagonal matrix. !>
[out]	LVL	!> LVL is INTEGER !> On exit, the number of levels on the computation tree. !>
[out]	ND	!> ND is INTEGER !> On exit, the number of nodes on the tree. !>
[out]	INODE	!> INODE is INTEGER array, dimension ( N ) !> On exit, centers of subproblems. !>
[out]	NDIML	!> NDIML is INTEGER array, dimension ( N ) !> On exit, row dimensions of left children. !>
[out]	NDIMR	!> NDIMR is INTEGER array, dimension ( N ) !> On exit, row dimensions of right children. !>
[in]	MSUB	!> MSUB is INTEGER !> On entry, the maximum row dimension each subproblem at the !> bottom of the tree can be of. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 104 of file dlasdt.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            LVL, MSUB, N, ND
*     ..
*     .. Array Arguments ..
      INTEGER            INODE( * ), NDIML( * ), NDIMR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IL, IR, LLST, MAXN, NCRNT, NLVL
      DOUBLE PRECISION   TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          dble, int, log, max
*     ..
*     .. Executable Statements ..
*
*     Find the number of levels on the tree.
*
      maxn = max( 1, n )
      temp = log( dble( maxn ) / dble( msub+1 ) ) / log( two )
      lvl = int( temp ) + 1
*
      i = n / 2
      inode( 1 ) = i + 1
      ndiml( 1 ) = i
      ndimr( 1 ) = n - i - 1
      il = 0
      ir = 1
      llst = 1
      DO 20 nlvl = 1, lvl - 1
*
*        Constructing the tree at (NLVL+1)-st level. The number of
*        nodes created on this level is LLST * 2.
*
         DO 10 i = 0, llst - 1
            il = il + 2
            ir = ir + 2
            ncrnt = llst + i
            ndiml( il ) = ndiml( ncrnt ) / 2
            ndimr( il ) = ndiml( ncrnt ) - ndiml( il ) - 1
            inode( il ) = inode( ncrnt ) - ndimr( il ) - 1
            ndiml( ir ) = ndimr( ncrnt ) / 2
            ndimr( ir ) = ndimr( ncrnt ) - ndiml( ir ) - 1
            inode( ir ) = inode( ncrnt ) + ndiml( ir ) + 1
   10    CONTINUE
         llst = llst*2
   20 CONTINUE
      nd = llst*2 - 1
*
      RETURN
*
*     End of DLASDT
*

dlaset()

subroutine dlaset	(	character	uplo,
		integer	m,
		integer	n,
		double precision	alpha,
		double precision	beta,
		double precision, dimension( lda, * )	a,
		integer	lda )

DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.

Download DLASET + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASET initializes an m-by-n matrix A to BETA on the diagonal and
!> ALPHA on the offdiagonals.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be set. !> = 'U': Upper triangular part is set; the strictly lower !> triangular part of A is not changed. !> = 'L': Lower triangular part is set; the strictly upper !> triangular part of A is not changed. !> Otherwise: All of the matrix A is set. !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in]	ALPHA	!> ALPHA is DOUBLE PRECISION !> The constant to which the offdiagonal elements are to be set. !>
[in]	BETA	!> BETA is DOUBLE PRECISION !> The constant to which the diagonal elements are to be set. !>
[out]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> On exit, the leading m-by-n submatrix of A is set as follows: !> !> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, !> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, !> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, !> !> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 109 of file dlaset.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, M, N
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( lsame( uplo, 'U' ) ) THEN
*
*        Set the strictly upper triangular or trapezoidal part of the
*        array to ALPHA.
*
         DO 20 j = 2, n
            DO 10 i = 1, min( j-1, m )
               a( i, j ) = alpha
   10       CONTINUE
   20    CONTINUE
*
      ELSE IF( lsame( uplo, 'L' ) ) THEN
*
*        Set the strictly lower triangular or trapezoidal part of the
*        array to ALPHA.
*
         DO 40 j = 1, min( m, n )
            DO 30 i = j + 1, m
               a( i, j ) = alpha
   30       CONTINUE
   40    CONTINUE
*
      ELSE
*
*        Set the leading m-by-n submatrix to ALPHA.
*
         DO 60 j = 1, n
            DO 50 i = 1, m
               a( i, j ) = alpha
   50       CONTINUE
   60    CONTINUE
      END IF
*
*     Set the first min(M,N) diagonal elements to BETA.
*
      DO 70 i = 1, min( m, n )
         a( i, i ) = beta
   70 CONTINUE
*
      RETURN
*
*     End of DLASET
*

dlasr()

subroutine dlasr	(	character	side,
		character	pivot,
		character	direct,
		integer	m,
		integer	n,
		double precision, dimension( * )	c,
		double precision, dimension( * )	s,
		double precision, dimension( lda, * )	a,
		integer	lda )

DLASR applies a sequence of plane rotations to a general rectangular matrix.

Download DLASR + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASR applies a sequence of plane rotations to a real matrix A,
!> from either the left or the right.
!>
!> When SIDE = 'L', the transformation takes the form
!>
!>    A := P*A
!>
!> and when SIDE = 'R', the transformation takes the form
!>
!>    A := A*P**T
!>
!> where P is an orthogonal matrix consisting of a sequence of z plane
!> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
!> and P**T is the transpose of P.
!>
!> When DIRECT = 'F' (Forward sequence), then
!>
!>    P = P(z-1) * ... * P(2) * P(1)
!>
!> and when DIRECT = 'B' (Backward sequence), then
!>
!>    P = P(1) * P(2) * ... * P(z-1)
!>
!> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
!>
!>    R(k) = (  c(k)  s(k) )
!>         = ( -s(k)  c(k) ).
!>
!> When PIVOT = 'V' (Variable pivot), the rotation is performed
!> for the plane (k,k+1), i.e., P(k) has the form
!>
!>    P(k) = (  1                                            )
!>           (       ...                                     )
!>           (              1                                )
!>           (                   c(k)  s(k)                  )
!>           (                  -s(k)  c(k)                  )
!>           (                                1              )
!>           (                                     ...       )
!>           (                                            1  )
!>
!> where R(k) appears as a rank-2 modification to the identity matrix in
!> rows and columns k and k+1.
!>
!> When PIVOT = 'T' (Top pivot), the rotation is performed for the
!> plane (1,k+1), so P(k) has the form
!>
!>    P(k) = (  c(k)                    s(k)                 )
!>           (         1                                     )
!>           (              ...                              )
!>           (                     1                         )
!>           ( -s(k)                    c(k)                 )
!>           (                                 1             )
!>           (                                      ...      )
!>           (                                             1 )
!>
!> where R(k) appears in rows and columns 1 and k+1.
!>
!> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
!> performed for the plane (k,z), giving P(k) the form
!>
!>    P(k) = ( 1                                             )
!>           (      ...                                      )
!>           (             1                                 )
!>           (                  c(k)                    s(k) )
!>           (                         1                     )
!>           (                              ...              )
!>           (                                     1         )
!>           (                 -s(k)                    c(k) )
!>
!> where R(k) appears in rows and columns k and z.  The rotations are
!> performed without ever forming P(k) explicitly.
!> 

Parameters

[in]	SIDE	!> SIDE is CHARACTER*1 !> Specifies whether the plane rotation matrix P is applied to !> A on the left or the right. !> = 'L': Left, compute A := P*A !> = 'R': Right, compute A:= A*P**T !>
[in]	PIVOT	!> PIVOT is CHARACTER*1 !> Specifies the plane for which P(k) is a plane rotation !> matrix. !> = 'V': Variable pivot, the plane (k,k+1) !> = 'T': Top pivot, the plane (1,k+1) !> = 'B': Bottom pivot, the plane (k,z) !>
[in]	DIRECT	!> DIRECT is CHARACTER*1 !> Specifies whether P is a forward or backward sequence of !> plane rotations. !> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) !> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. If m <= 1, an immediate !> return is effected. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. If n <= 1, an !> immediate return is effected. !>
[in]	C	!> C is DOUBLE PRECISION array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The cosines c(k) of the plane rotations. !>
[in]	S	!> S is DOUBLE PRECISION array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The sines s(k) of the plane rotations. The 2-by-2 plane !> rotation part of the matrix P(k), R(k), has the form !> R(k) = ( c(k) s(k) ) !> ( -s(k) c(k) ). !>
[in,out]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> The M-by-N matrix A. On exit, A is overwritten by P*A if !> SIDE = 'L' or by A*P**T if SIDE = 'R'. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 198 of file dlasr.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
      DOUBLE PRECISION   CTEMP, STEMP, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      info = 0
      IF( .NOT.( lsame( side, 'L' ) .OR. lsame( side, 'R' ) ) ) THEN
         info = 1
      ELSE IF( .NOT.( lsame( pivot, 'V' ) .OR. lsame( pivot,
     $         'T' ) .OR. lsame( pivot, 'B' ) ) ) THEN
         info = 2
      ELSE IF( .NOT.( lsame( direct, 'F' ) .OR. lsame( direct, 'B' ) ) )
     $          THEN
         info = 3
      ELSE IF( m.LT.0 ) THEN
         info = 4
      ELSE IF( n.LT.0 ) THEN
         info = 5
      ELSE IF( lda.LT.max( 1, m ) ) THEN
         info = 9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASR ', info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
     $   RETURN
      IF( lsame( side, 'L' ) ) THEN
*
*        Form  P * A
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 20 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 10 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 40 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 30 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 60 j = 2, m
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 50 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 80 j = m, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 70 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 100 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 90 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 120 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 110 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( lsame( side, 'R' ) ) THEN
*
*        Form A * P**T
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 140 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 130 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 160 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 150 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 180 j = 2, n
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 170 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 200 j = n, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 190 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 220 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 210 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 240 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 230 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DLASR
*

dlassq()

subroutine dlassq	(	integer	n,
		real(wp), dimension(*)	x,
		integer	incx,
		real(wp)	scl,
		real(wp)	sumsq )

DLASSQ updates a sum of squares represented in scaled form.

Download DLASSQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASSQ  returns the values  scl  and  smsq  such that
!>
!>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!>
!> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!>    we require:   scale >= sqrt( TINY*EPS ) / sbig   on entry,
!> and if 0 < scale * sqrt( sumsq ) < tsml then
!>    we require:   scale <= sqrt( HUGE ) / ssml       on entry,
!> where
!>    tbig -- upper threshold for values whose square is representable;
!>    sbig -- scaling constant for big numbers; \see la_constants.f90
!>    tsml -- lower threshold for values whose square is representable;
!>    ssml -- scaling constant for small numbers; \see la_constants.f90
!> and
!>    TINY*EPS -- tiniest representable number;
!>    HUGE     -- biggest representable number.
!>
!> 

Parameters

[in]	N	!> N is INTEGER !> The number of elements to be used from the vector x. !>
[in]	X	!> X is DOUBLE PRECISION array, dimension (1+(N-1)*abs(INCX)) !> The vector for which a scaled sum of squares is computed. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !>
[in]	INCX	!> INCX is INTEGER !> The increment between successive values of the vector x. !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX = 0, x isn't a vector so there is no need to call !> this subroutine. If you call it anyway, it will count x(1) !> in the vector norm N times. !>
[in,out]	SCALE	!> SCALE is DOUBLE PRECISION !> On entry, the value scale in the equation above. !> On exit, SCALE is overwritten with scl , the scaling factor !> for the sum of squares. !>
[in,out]	SUMSQ	!> SUMSQ is DOUBLE PRECISION !> On entry, the value sumsq in the equation above. !> On exit, SUMSQ is overwritten with smsq , the basic sum of !> squares from which scl has been factored out. !>

Author

Edward Anderson, Lockheed Martin

Contributors:

Weslley Pereira, University of Colorado Denver, USA Nick Papior, Technical University of Denmark, DK

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> 

Definition at line 136 of file dlassq.f90.

   use la_constants, &
      only: wp=>dp, zero=>dzero, one=>done, &
            sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml
   use la_xisnan
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Scalar Arguments ..
   integer :: incx, n
   real(wp) :: scl, sumsq
!  ..
!  .. Array Arguments ..
   real(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, ymax, ymin
!  ..
!
!  Quick return if possible
!
   if( la_isnan(scl) .or. la_isnan(sumsq) ) return
   if( sumsq == zero ) scl = one
   if( scl == zero ) then
      scl = one
      sumsq = zero
   end if
   if (n <= 0) then
      return
   end if
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(x(ix))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Put the existing sum of squares into one of the accumulators
!
   if( sumsq > zero ) then
      ax = scl*sqrt( sumsq )
      if (ax > tbig) then
!        We assume scl >= sqrt( TINY*EPS ) / sbig
         abig = abig + (scl*sbig)**2 * sumsq
      else if (ax < tsml) then
!        We assume scl <= sqrt( HUGE ) / ssml
         if (notbig) asml = asml + (scl*ssml)**2 * sumsq
      else
         amed = amed + scl**2 * sumsq
      end if
   end if
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range or zero
!
      scl = one
      sumsq = amed
   end if
   return

dlasv2()

subroutine dlasv2	(	double precision	f,
		double precision	g,
		double precision	h,
		double precision	ssmin,
		double precision	ssmax,
		double precision	snr,
		double precision	csr,
		double precision	snl,
		double precision	csl )

DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.

Download DLASV2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLASV2 computes the singular value decomposition of a 2-by-2
!> triangular matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
!> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
!> right singular vectors for abs(SSMAX), giving the decomposition
!>
!>    [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
!>    [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
!> 

Parameters

[in]	F	!> F is DOUBLE PRECISION !> The (1,1) element of the 2-by-2 matrix. !>
[in]	G	!> G is DOUBLE PRECISION !> The (1,2) element of the 2-by-2 matrix. !>
[in]	H	!> H is DOUBLE PRECISION !> The (2,2) element of the 2-by-2 matrix. !>
[out]	SSMIN	!> SSMIN is DOUBLE PRECISION !> abs(SSMIN) is the smaller singular value. !>
[out]	SSMAX	!> SSMAX is DOUBLE PRECISION !> abs(SSMAX) is the larger singular value. !>
[out]	SNL	!> SNL is DOUBLE PRECISION !>
[out]	CSL	!> CSL is DOUBLE PRECISION !> The vector (CSL, SNL) is a unit left singular vector for the !> singular value abs(SSMAX). !>
[out]	SNR	!> SNR is DOUBLE PRECISION !>
[out]	CSR	!> CSR is DOUBLE PRECISION !> The vector (CSR, SNR) is a unit right singular vector for the !> singular value abs(SSMAX). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  Any input parameter may be aliased with any output parameter.
!>
!>  Barring over/underflow and assuming a guard digit in subtraction, all
!>  output quantities are correct to within a few units in the last
!>  place (ulps).
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> 

Definition at line 137 of file dlasv2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      parameter( zero = 0.0d0 )
      DOUBLE PRECISION   HALF
      parameter( half = 0.5d0 )
      DOUBLE PRECISION   ONE
      parameter( one = 1.0d0 )
      DOUBLE PRECISION   TWO
      parameter( two = 2.0d0 )
      DOUBLE PRECISION   FOUR
      parameter( four = 4.0d0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            GASMAL, SWAP
      INTEGER            PMAX
      DOUBLE PRECISION   A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
     $                   MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           dlamch
*     ..
*     .. Executable Statements ..
*
      ft = f
      fa = abs( ft )
      ht = h
      ha = abs( h )
*
*     PMAX points to the maximum absolute element of matrix
*       PMAX = 1 if F largest in absolute values
*       PMAX = 2 if G largest in absolute values
*       PMAX = 3 if H largest in absolute values
*
      pmax = 1
      swap = ( ha.GT.fa )
      IF( swap ) THEN
         pmax = 3
         temp = ft
         ft = ht
         ht = temp
         temp = fa
         fa = ha
         ha = temp
*
*        Now FA .ge. HA
*
      END IF
      gt = g
      ga = abs( gt )
      IF( ga.EQ.zero ) THEN
*
*        Diagonal matrix
*
         ssmin = ha
         ssmax = fa
         clt = one
         crt = one
         slt = zero
         srt = zero
      ELSE
         gasmal = .true.
         IF( ga.GT.fa ) THEN
            pmax = 2
            IF( ( fa / ga ).LT.dlamch( 'EPS' ) ) THEN
*
*              Case of very large GA
*
               gasmal = .false.
               ssmax = ga
               IF( ha.GT.one ) THEN
                  ssmin = fa / ( ga / ha )
               ELSE
                  ssmin = ( fa / ga )*ha
               END IF
               clt = one
               slt = ht / gt
               srt = one
               crt = ft / gt
            END IF
         END IF
         IF( gasmal ) THEN
*
*           Normal case
*
            d = fa - ha
            IF( d.EQ.fa ) THEN
*
*              Copes with infinite F or H
*
               l = one
            ELSE
               l = d / fa
            END IF
*
*           Note that 0 .le. L .le. 1
*
            m = gt / ft
*
*           Note that abs(M) .le. 1/macheps
*
            t = two - l
*
*           Note that T .ge. 1
*
            mm = m*m
            tt = t*t
            s = sqrt( tt+mm )
*
*           Note that 1 .le. S .le. 1 + 1/macheps
*
            IF( l.EQ.zero ) THEN
               r = abs( m )
            ELSE
               r = sqrt( l*l+mm )
            END IF
*
*           Note that 0 .le. R .le. 1 + 1/macheps
*
            a = half*( s+r )
*
*           Note that 1 .le. A .le. 1 + abs(M)
*
            ssmin = ha / a
            ssmax = fa*a
            IF( mm.EQ.zero ) THEN
*
*              Note that M is very tiny
*
               IF( l.EQ.zero ) THEN
                  t = sign( two, ft )*sign( one, gt )
               ELSE
                  t = gt / sign( d, ft ) + m / t
               END IF
            ELSE
               t = ( m / ( s+t )+m / ( r+l ) )*( one+a )
            END IF
            l = sqrt( t*t+four )
            crt = two / l
            srt = t / l
            clt = ( crt+srt*m ) / a
            slt = ( ht / ft )*srt / a
         END IF
      END IF
      IF( swap ) THEN
         csl = srt
         snl = crt
         csr = slt
         snr = clt
      ELSE
         csl = clt
         snl = slt
         csr = crt
         snr = srt
      END IF
*
*     Correct signs of SSMAX and SSMIN
*
      IF( pmax.EQ.1 )
     $   tsign = sign( one, csr )*sign( one, csl )*sign( one, f )
      IF( pmax.EQ.2 )
     $   tsign = sign( one, snr )*sign( one, csl )*sign( one, g )
      IF( pmax.EQ.3 )
     $   tsign = sign( one, snr )*sign( one, snl )*sign( one, h )
      ssmax = sign( ssmax, tsign )
      ssmin = sign( ssmin, tsign*sign( one, f )*sign( one, h ) )
      RETURN
*
*     End of DLASV2
*

ieeeck()

integer function ieeeck	(	integer	ispec,
		real	zero,
		real	one )

IEEECK

Download IEEECK + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> IEEECK is called from the ILAENV to verify that Infinity and
!> possibly NaN arithmetic is safe (i.e. will not trap).
!> 

Parameters

[in]	ISPEC	!> ISPEC is INTEGER !> Specifies whether to test just for inifinity arithmetic !> or whether to test for infinity and NaN arithmetic. !> = 0: Verify infinity arithmetic only. !> = 1: Verify infinity and NaN arithmetic. !>
[in]	ZERO	!> ZERO is REAL !> Must contain the value 0.0 !> This is passed to prevent the compiler from optimizing !> away this code. !>
[in]	ONE	!> ONE is REAL !> Must contain the value 1.0 !> This is passed to prevent the compiler from optimizing !> away this code. !> !> RETURN VALUE: INTEGER !> = 0: Arithmetic failed to produce the correct answers !> = 1: Arithmetic produced the correct answers !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 81 of file ieeeck.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
     $                   NEGZRO, NEWZRO, POSINF
*     ..
*     .. Executable Statements ..
      ieeeck = 1
*
      posinf = one / zero
      IF( posinf.LE.one ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      neginf = -one / zero
      IF( neginf.GE.zero ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      negzro = one / ( neginf+one )
      IF( negzro.NE.zero ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      neginf = one / negzro
      IF( neginf.GE.zero ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      newzro = negzro + zero
      IF( newzro.NE.zero ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      posinf = one / newzro
      IF( posinf.LE.one ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      neginf = neginf*posinf
      IF( neginf.GE.zero ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      posinf = posinf*posinf
      IF( posinf.LE.one ) THEN
         ieeeck = 0
         RETURN
      END IF
*
*
*
*
*     Return if we were only asked to check infinity arithmetic
*
      IF( ispec.EQ.0 )
     $   RETURN
*
      nan1 = posinf + neginf
*
      nan2 = posinf / neginf
*
      nan3 = posinf / posinf
*
      nan4 = posinf*zero
*
      nan5 = neginf*negzro
*
      nan6 = nan5*zero
*
      IF( nan1.EQ.nan1 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      IF( nan2.EQ.nan2 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      IF( nan3.EQ.nan3 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      IF( nan4.EQ.nan4 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      IF( nan5.EQ.nan5 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      IF( nan6.EQ.nan6 ) THEN
         ieeeck = 0
         RETURN
      END IF
*
      RETURN

iladlc()

integer function iladlc	(	integer	m,
		integer	n,
		double precision, dimension( lda, * )	a,
		integer	lda )

ILADLC scans a matrix for its last non-zero column.

Download ILADLC + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> ILADLC scans A for its last non-zero column.
!> 

Parameters

[in]	M	!> M is INTEGER !> The number of rows of the matrix A. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. !>
[in]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 77 of file iladlc.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            M, N, LDA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      parameter( zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER I
*     ..
*     .. Executable Statements ..
*
*     Quick test for the common case where one corner is non-zero.
      IF( n.EQ.0 ) THEN
         iladlc = n
      ELSE IF( a(1, n).NE.zero .OR. a(m, n).NE.zero ) THEN
         iladlc = n
      ELSE
*     Now scan each column from the end, returning with the first non-zero.
         DO iladlc = n, 1, -1
            DO i = 1, m
               IF( a(i, iladlc).NE.zero ) RETURN
            END DO
         END DO
      END IF
      RETURN

iladlr()

integer function iladlr	(	integer	m,
		integer	n,
		double precision, dimension( lda, * )	a,
		integer	lda )

ILADLR scans a matrix for its last non-zero row.

Download ILADLR + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> ILADLR scans A for its last non-zero row.
!> 

Parameters

[in]	M	!> M is INTEGER !> The number of rows of the matrix A. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. !>
[in]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> The m by n matrix A. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 77 of file iladlr.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            M, N, LDA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      parameter( zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER I, J
*     ..
*     .. Executable Statements ..
*
*     Quick test for the common case where one corner is non-zero.
      IF( m.EQ.0 ) THEN
         iladlr = m
      ELSE IF( a(m, 1).NE.zero .OR. a(m, n).NE.zero ) THEN
         iladlr = m
      ELSE
*     Scan up each column tracking the last zero row seen.
         iladlr = 0
         DO j = 1, n
            i=m
            DO WHILE((a(max(i,1),j).EQ.zero).AND.(i.GE.1))
               i=i-1
            ENDDO
            iladlr = max( iladlr, i )
         END DO
      END IF
      RETURN

ilaenv()

integer function ilaenv	(	integer	ispec,
		character*( * )	name,
		character*( * )	opts,
		integer	n1,
		integer	n2,
		integer	n3,
		integer	n4 )

ILAENV

Download ILAENV + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> ILAENV is called from the LAPACK routines to choose problem-dependent
!> parameters for the local environment.  See ISPEC for a description of
!> the parameters.
!>
!> ILAENV returns an INTEGER
!> if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
!> if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.
!>
!> This version provides a set of parameters which should give good,
!> but not optimal, performance on many of the currently available
!> computers.  Users are encouraged to modify this subroutine to set
!> the tuning parameters for their particular machine using the option
!> and problem size information in the arguments.
!>
!> This routine will not function correctly if it is converted to all
!> lower case.  Converting it to all upper case is allowed.
!> 

Parameters

[in]	ISPEC	!> ISPEC is INTEGER !> Specifies the parameter to be returned as the value of !> ILAENV. !> = 1: the optimal blocksize; if this value is 1, an unblocked !> algorithm will give the best performance. !> = 2: the minimum block size for which the block routine !> should be used; if the usable block size is less than !> this value, an unblocked routine should be used. !> = 3: the crossover point (in a block routine, for N less !> than this value, an unblocked routine should be used) !> = 4: the number of shifts, used in the nonsymmetric !> eigenvalue routines (DEPRECATED) !> = 5: the minimum column dimension for blocking to be used; !> rectangular blocks must have dimension at least k by m, !> where k is given by ILAENV(2,...) and m by ILAENV(5,...) !> = 6: the crossover point for the SVD (when reducing an m by n !> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds !> this value, a QR factorization is used first to reduce !> the matrix to a triangular form.) !> = 7: the number of processors !> = 8: the crossover point for the multishift QR method !> for nonsymmetric eigenvalue problems (DEPRECATED) !> = 9: maximum size of the subproblems at the bottom of the !> computation tree in the divide-and-conquer algorithm !> (used by xGELSD and xGESDD) !> =10: ieee infinity and NaN arithmetic can be trusted not to trap !> =11: infinity arithmetic can be trusted not to trap !> 12 <= ISPEC <= 17: !> xHSEQR or related subroutines, !> see IPARMQ for detailed explanation !>
[in]	NAME	!> NAME is CHARACTER*(*) !> The name of the calling subroutine, in either upper case or !> lower case. !>
[in]	OPTS	!> OPTS is CHARACTER*(*) !> The character options to the subroutine NAME, concatenated !> into a single character string. For example, UPLO = 'U', !> TRANS = 'T', and DIAG = 'N' for a triangular routine would !> be specified as OPTS = 'UTN'. !>
[in]	N1	!> N1 is INTEGER !>
[in]	N2	!> N2 is INTEGER !>
[in]	N3	!> N3 is INTEGER !>
[in]	N4	!> N4 is INTEGER !> Problem dimensions for the subroutine NAME; these may not all !> be required. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  The following conventions have been used when calling ILAENV from the
!>  LAPACK routines:
!>  1)  OPTS is a concatenation of all of the character options to
!>      subroutine NAME, in the same order that they appear in the
!>      argument list for NAME, even if they are not used in determining
!>      the value of the parameter specified by ISPEC.
!>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
!>      that they appear in the argument list for NAME.  N1 is used
!>      first, N2 second, and so on, and unused problem dimensions are
!>      passed a value of -1.
!>  3)  The parameter value returned by ILAENV is checked for validity in
!>      the calling subroutine.  For example, ILAENV is used to retrieve
!>      the optimal blocksize for STRTRI as follows:
!>
!>      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!>      IF( NB.LE.1 ) NB = MAX( 1, N )
!> 

Purpose:

!>
!> ILAENV returns problem-dependent parameters for the local
!> environment.  See ISPEC for a description of the parameters.
!>
!> In this version, the problem-dependent parameters are contained in
!> the integer array IPARMS in the common block CLAENV and the value
!> with index ISPEC is copied to ILAENV.  This version of ILAENV is
!> to be used in conjunction with XLAENV in TESTING and TIMING.
!> 

Parameters

[in]	ISPEC	!> ISPEC is INTEGER !> Specifies the parameter to be returned as the value of !> ILAENV. !> = 1: the optimal blocksize; if this value is 1, an unblocked !> algorithm will give the best performance. !> = 2: the minimum block size for which the block routine !> should be used; if the usable block size is less than !> this value, an unblocked routine should be used. !> = 3: the crossover point (in a block routine, for N less !> than this value, an unblocked routine should be used) !> = 4: the number of shifts, used in the nonsymmetric !> eigenvalue routines !> = 5: the minimum column dimension for blocking to be used; !> rectangular blocks must have dimension at least k by m, !> where k is given by ILAENV(2,...) and m by ILAENV(5,...) !> = 6: the crossover point for the SVD (when reducing an m by n !> matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds !> this value, a QR factorization is used first to reduce !> the matrix to a triangular form.) !> = 7: the number of processors !> = 8: the crossover point for the multishift QR and QZ methods !> for nonsymmetric eigenvalue problems. !> = 9: maximum size of the subproblems at the bottom of the !> computation tree in the divide-and-conquer algorithm !> =10: ieee NaN arithmetic can be trusted not to trap !> =11: infinity arithmetic can be trusted not to trap !> 12 <= ISPEC <= 16: !> xHSEQR or one of its subroutines, !> see IPARMQ for detailed explanation !> !> Other specifications (up to 100) can be added later. !>
[in]	NAME	!> NAME is CHARACTER*(*) !> The name of the calling subroutine. !>
[in]	OPTS	!> OPTS is CHARACTER*(*) !> The character options to the subroutine NAME, concatenated !> into a single character string. For example, UPLO = 'U', !> TRANS = 'T', and DIAG = 'N' for a triangular routine would !> be specified as OPTS = 'UTN'. !>
[in]	N1	!> N1 is INTEGER !>
[in]	N2	!> N2 is INTEGER !>
[in]	N3	!> N3 is INTEGER !>
[in]	N4	!> N4 is INTEGER !> !> Problem dimensions for the subroutine NAME; these may not all !> be required. !>

Returns

ILAENV

!>          ILAENV is INTEGER
!>          >= 0: the value of the parameter specified by ISPEC
!>          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  The following conventions have been used when calling ILAENV from the
!>  LAPACK routines:
!>  1)  OPTS is a concatenation of all of the character options to
!>      subroutine NAME, in the same order that they appear in the
!>      argument list for NAME, even if they are not used in determining
!>      the value of the parameter specified by ISPEC.
!>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
!>      that they appear in the argument list for NAME.  N1 is used
!>      first, N2 second, and so on, and unused problem dimensions are
!>      passed a value of -1.
!>  3)  The parameter value returned by ILAENV is checked for validity in
!>      the calling subroutine.  For example, ILAENV is used to retrieve
!>      the optimal blocksize for STRTRI as follows:
!>
!>      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!>      IF( NB.LE.1 ) NB = MAX( 1, N )
!> 

Definition at line 161 of file ilaenv.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IC, IZ, NB, NBMIN, NX
      LOGICAL            CNAME, SNAME, TWOSTAGE
      CHARACTER          C1*1, C2*2, C4*2, C3*3, SUBNAM*16
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          char, ichar, int, min, real
*     ..
*     .. External Functions ..
      INTEGER            IEEECK, IPARMQ, IPARAM2STAGE
      EXTERNAL           ieeeck, iparmq, iparam2stage
*     ..
*     .. Executable Statements ..
*
      GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
     $        130, 140, 150, 160, 160, 160, 160, 160, 160)ispec
*
*     Invalid value for ISPEC
*
      ilaenv = -1
      RETURN
*
   10 CONTINUE
*
*     Convert NAME to upper case if the first character is lower case.
*
      ilaenv = 1
      subnam = name
      ic = ichar( subnam( 1: 1 ) )
      iz = ichar( 'Z' )
      IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN
*
*        ASCII character set
*
         IF( ic.GE.97 .AND. ic.LE.122 ) THEN
            subnam( 1: 1 ) = char( ic-32 )
            DO 20 i = 2, 6
               ic = ichar( subnam( i: i ) )
               IF( ic.GE.97 .AND. ic.LE.122 )
     $            subnam( i: i ) = char( ic-32 )
   20       CONTINUE
         END IF
*
      ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN
*
*        EBCDIC character set
*
         IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
     $       ( ic.GE.145 .AND. ic.LE.153 ) .OR.
     $       ( ic.GE.162 .AND. ic.LE.169 ) ) THEN
            subnam( 1: 1 ) = char( ic+64 )
            DO 30 i = 2, 6
               ic = ichar( subnam( i: i ) )
               IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
     $             ( ic.GE.145 .AND. ic.LE.153 ) .OR.
     $             ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i:
     $             i ) = char( ic+64 )
   30       CONTINUE
         END IF
*
      ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN
*
*        Prime machines:  ASCII+128
*
         IF( ic.GE.225 .AND. ic.LE.250 ) THEN
            subnam( 1: 1 ) = char( ic-32 )
            DO 40 i = 2, 6
               ic = ichar( subnam( i: i ) )
               IF( ic.GE.225 .AND. ic.LE.250 )
     $            subnam( i: i ) = char( ic-32 )
   40       CONTINUE
         END IF
      END IF
*
      c1 = subnam( 1: 1 )
      sname = c1.EQ.'S' .OR. c1.EQ.'D'
      cname = c1.EQ.'C' .OR. c1.EQ.'Z'
      IF( .NOT.( cname .OR. sname ) )
     $   RETURN
      c2 = subnam( 2: 3 )
      c3 = subnam( 4: 6 )
      c4 = c3( 2: 3 )
      twostage = len( subnam ).GE.11
     $           .AND. subnam( 11: 11 ).EQ.'2'
*
      GO TO ( 50, 60, 70 )ispec
*
   50 CONTINUE
*
*     ISPEC = 1:  block size
*
*     In these examples, separate code is provided for setting NB for
*     real and complex.  We assume that NB will take the same value in
*     single or double precision.
*
      nb = 1
*
      IF( subnam(2:6).EQ.'LAORH' ) THEN
*
*        This is for *LAORHR_GETRFNP routine
*
         IF( sname ) THEN
             nb = 32
         ELSE
             nb = 32
         END IF
      ELSE IF( c2.EQ.'GE' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         ELSE IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR.
     $            c3.EQ.'QLF' ) THEN
            IF( sname ) THEN
               nb = 32
            ELSE
               nb = 32
            END IF
         ELSE IF( c3.EQ.'QR ') THEN
            IF( n3 .EQ. 1) THEN
               IF( sname ) THEN
*     M*N
                  IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
                     nb = n1
                  ELSE
                     nb = 32768/n2
                  END IF
               ELSE
                  IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
                     nb = n1
                  ELSE
                     nb = 32768/n2
                  END IF
               END IF
            ELSE
               IF( sname ) THEN
                  nb = 1
               ELSE
                  nb = 1
               END IF
            END IF
         ELSE IF( c3.EQ.'LQ ') THEN
            IF( n3 .EQ. 2) THEN
               IF( sname ) THEN
*     M*N
                  IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
                     nb = n1
                  ELSE
                     nb = 32768/n2
                  END IF
               ELSE
                  IF ((n1*n2.LE.131072).OR.(n1.LE.8192)) THEN
                     nb = n1
                  ELSE
                     nb = 32768/n2
                  END IF
               END IF
            ELSE
               IF( sname ) THEN
                  nb = 1
               ELSE
                  nb = 1
               END IF
            END IF
         ELSE IF( c3.EQ.'HRD' ) THEN
            IF( sname ) THEN
               nb = 32
            ELSE
               nb = 32
            END IF
         ELSE IF( c3.EQ.'BRD' ) THEN
            IF( sname ) THEN
               nb = 32
            ELSE
               nb = 32
            END IF
         ELSE IF( c3.EQ.'TRI' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         END IF
      ELSE IF( c2.EQ.'PO' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         END IF
      ELSE IF( c2.EQ.'SY' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               IF( twostage ) THEN
                  nb = 192
               ELSE
                  nb = 64
               END IF
            ELSE
               IF( twostage ) THEN
                  nb = 192
               ELSE
                  nb = 64
               END IF
            END IF
         ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
            nb = 32
         ELSE IF( sname .AND. c3.EQ.'GST' ) THEN
            nb = 64
         END IF
      ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( twostage ) THEN
               nb = 192
            ELSE
               nb = 64
            END IF
         ELSE IF( c3.EQ.'TRD' ) THEN
            nb = 32
         ELSE IF( c3.EQ.'GST' ) THEN
            nb = 64
         END IF
      ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nb = 32
            END IF
         ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nb = 32
            END IF
         END IF
      ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nb = 32
            END IF
         ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nb = 32
            END IF
         END IF
      ELSE IF( c2.EQ.'GB' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               IF( n4.LE.64 ) THEN
                  nb = 1
               ELSE
                  nb = 32
               END IF
            ELSE
               IF( n4.LE.64 ) THEN
                  nb = 1
               ELSE
                  nb = 32
               END IF
            END IF
         END IF
      ELSE IF( c2.EQ.'PB' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               IF( n2.LE.64 ) THEN
                  nb = 1
               ELSE
                  nb = 32
               END IF
            ELSE
               IF( n2.LE.64 ) THEN
                  nb = 1
               ELSE
                  nb = 32
               END IF
            END IF
         END IF
      ELSE IF( c2.EQ.'TR' ) THEN
         IF( c3.EQ.'TRI' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         ELSE IF ( c3.EQ.'EVC' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         END IF
      ELSE IF( c2.EQ.'LA' ) THEN
         IF( c3.EQ.'UUM' ) THEN
            IF( sname ) THEN
               nb = 64
            ELSE
               nb = 64
            END IF
         END IF
      ELSE IF( sname .AND. c2.EQ.'ST' ) THEN
         IF( c3.EQ.'EBZ' ) THEN
            nb = 1
         END IF
      ELSE IF( c2.EQ.'GG' ) THEN
         nb = 32
         IF( c3.EQ.'HD3' ) THEN
            IF( sname ) THEN
               nb = 32
            ELSE
               nb = 32
            END IF
         END IF
      END IF
      ilaenv = nb
      RETURN
*
   60 CONTINUE
*
*     ISPEC = 2:  minimum block size
*
      nbmin = 2
      IF( c2.EQ.'GE' ) THEN
         IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ.
     $       'QLF' ) THEN
            IF( sname ) THEN
               nbmin = 2
            ELSE
               nbmin = 2
            END IF
         ELSE IF( c3.EQ.'HRD' ) THEN
            IF( sname ) THEN
               nbmin = 2
            ELSE
               nbmin = 2
            END IF
         ELSE IF( c3.EQ.'BRD' ) THEN
            IF( sname ) THEN
               nbmin = 2
            ELSE
               nbmin = 2
            END IF
         ELSE IF( c3.EQ.'TRI' ) THEN
            IF( sname ) THEN
               nbmin = 2
            ELSE
               nbmin = 2
            END IF
         END IF
      ELSE IF( c2.EQ.'SY' ) THEN
         IF( c3.EQ.'TRF' ) THEN
            IF( sname ) THEN
               nbmin = 8
            ELSE
               nbmin = 8
            END IF
         ELSE IF( sname .AND. c3.EQ.'TRD' ) THEN
            nbmin = 2
         END IF
      ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
         IF( c3.EQ.'TRD' ) THEN
            nbmin = 2
         END IF
      ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nbmin = 2
            END IF
         ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nbmin = 2
            END IF
         END IF
      ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nbmin = 2
            END IF
         ELSE IF( c3( 1: 1 ).EQ.'M' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nbmin = 2
            END IF
         END IF
      ELSE IF( c2.EQ.'GG' ) THEN
         nbmin = 2
         IF( c3.EQ.'HD3' ) THEN
            nbmin = 2
         END IF
      END IF
      ilaenv = nbmin
      RETURN
*
   70 CONTINUE
*
*     ISPEC = 3:  crossover point
*
      nx = 0
      IF( c2.EQ.'GE' ) THEN
         IF( c3.EQ.'QRF' .OR. c3.EQ.'RQF' .OR. c3.EQ.'LQF' .OR. c3.EQ.
     $       'QLF' ) THEN
            IF( sname ) THEN
               nx = 128
            ELSE
               nx = 128
            END IF
         ELSE IF( c3.EQ.'HRD' ) THEN
            IF( sname ) THEN
               nx = 128
            ELSE
               nx = 128
            END IF
         ELSE IF( c3.EQ.'BRD' ) THEN
            IF( sname ) THEN
               nx = 128
            ELSE
               nx = 128
            END IF
         END IF
      ELSE IF( c2.EQ.'SY' ) THEN
         IF( sname .AND. c3.EQ.'TRD' ) THEN
            nx = 32
         END IF
      ELSE IF( cname .AND. c2.EQ.'HE' ) THEN
         IF( c3.EQ.'TRD' ) THEN
            nx = 32
         END IF
      ELSE IF( sname .AND. c2.EQ.'OR' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nx = 128
            END IF
         END IF
      ELSE IF( cname .AND. c2.EQ.'UN' ) THEN
         IF( c3( 1: 1 ).EQ.'G' ) THEN
            IF( c4.EQ.'QR' .OR. c4.EQ.'RQ' .OR. c4.EQ.'LQ' .OR. c4.EQ.
     $          'QL' .OR. c4.EQ.'HR' .OR. c4.EQ.'TR' .OR. c4.EQ.'BR' )
     $           THEN
               nx = 128
            END IF
         END IF
      ELSE IF( c2.EQ.'GG' ) THEN
         nx = 128
         IF( c3.EQ.'HD3' ) THEN
            nx = 128
         END IF
      END IF
      ilaenv = nx
      RETURN
*
   80 CONTINUE
*
*     ISPEC = 4:  number of shifts (used by xHSEQR)
*
      ilaenv = 6
      RETURN
*
   90 CONTINUE
*
*     ISPEC = 5:  minimum column dimension (not used)
*
      ilaenv = 2
      RETURN
*
  100 CONTINUE
*
*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
*
      ilaenv = int( real( min( n1, n2 ) )*1.6e0 )
      RETURN
*
  110 CONTINUE
*
*     ISPEC = 7:  number of processors (not used)
*
      ilaenv = 1
      RETURN
*
  120 CONTINUE
*
*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
*
      ilaenv = 50
      RETURN
*
  130 CONTINUE
*
*     ISPEC = 9:  maximum size of the subproblems at the bottom of the
*                 computation tree in the divide-and-conquer algorithm
*                 (used by xGELSD and xGESDD)
*
      ilaenv = 25
      RETURN
*
  140 CONTINUE
*
*     ISPEC = 10: ieee and infinity NaN arithmetic can be trusted not to trap
*
*     ILAENV = 0
      ilaenv = 1
      IF( ilaenv.EQ.1 ) THEN
         ilaenv = ieeeck( 1, 0.0, 1.0 )
      END IF
      RETURN
*
  150 CONTINUE
*
*     ISPEC = 11: ieee infinity arithmetic can be trusted not to trap
*
*     ILAENV = 0
      ilaenv = 1
      IF( ilaenv.EQ.1 ) THEN
         ilaenv = ieeeck( 0, 0.0, 1.0 )
      END IF
      RETURN
*
  160 CONTINUE
*
*     12 <= ISPEC <= 17: xHSEQR or related subroutines.
*
      ilaenv = iparmq( ispec, name, opts, n1, n2, n3, n4 )
      RETURN
*
*     End of ILAENV
*

ilaenv2stage()

integer function ilaenv2stage	(	integer	ispec,
		character*( * )	name,
		character*( * )	opts,
		integer	n1,
		integer	n2,
		integer	n3,
		integer	n4 )

ILAENV2STAGE

Download ILAENV2STAGE + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> ILAENV2STAGE is called from the LAPACK routines to choose problem-dependent
!> parameters for the local environment.  See ISPEC for a description of
!> the parameters.
!> It sets problem and machine dependent parameters useful for *_2STAGE and
!> related subroutines.
!>
!> ILAENV2STAGE returns an INTEGER
!> if ILAENV2STAGE >= 0: ILAENV2STAGE returns the value of the parameter
!>                       specified by ISPEC
!> if ILAENV2STAGE < 0:  if ILAENV2STAGE = -k, the k-th argument had an
!>                       illegal value.
!>
!> This version provides a set of parameters which should give good,
!> but not optimal, performance on many of the currently available
!> computers for the 2-stage solvers. Users are encouraged to modify this
!> subroutine to set the tuning parameters for their particular machine using
!> the option and problem size information in the arguments.
!>
!> This routine will not function correctly if it is converted to all
!> lower case.  Converting it to all upper case is allowed.
!> 

Parameters

[in]	ISPEC	!> ISPEC is INTEGER !> Specifies the parameter to be returned as the value of !> ILAENV2STAGE. !> = 1: the optimal blocksize nb for the reduction to BAND !> !> = 2: the optimal blocksize ib for the eigenvectors !> singular vectors update routine !> !> = 3: The length of the array that store the Housholder !> representation for the second stage !> Band to Tridiagonal or Bidiagonal !> !> = 4: The workspace needed for the routine in input. !> !> = 5: For future release. !>
[in]	NAME	!> NAME is CHARACTER*(*) !> The name of the calling subroutine, in either upper case or !> lower case. !>
[in]	OPTS	!> OPTS is CHARACTER*(*) !> The character options to the subroutine NAME, concatenated !> into a single character string. For example, UPLO = 'U', !> TRANS = 'T', and DIAG = 'N' for a triangular routine would !> be specified as OPTS = 'UTN'. !>
[in]	N1	!> N1 is INTEGER !>
[in]	N2	!> N2 is INTEGER !>
[in]	N3	!> N3 is INTEGER !>
[in]	N4	!> N4 is INTEGER !> Problem dimensions for the subroutine NAME; these may not all !> be required. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Nick R. Papior

Further Details:

!>
!>  The following conventions have been used when calling ILAENV2STAGE
!> from the LAPACK routines:
!>  1)  OPTS is a concatenation of all of the character options to
!>      subroutine NAME, in the same order that they appear in the
!>      argument list for NAME, even if they are not used in determining
!>      the value of the parameter specified by ISPEC.
!>  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
!>      that they appear in the argument list for NAME.  N1 is used
!>      first, N2 second, and so on, and unused problem dimensions are
!>      passed a value of -1.
!>  3)  The parameter value returned by ILAENV2STAGE is checked for validity in
!>      the calling subroutine.
!>     
!> 

Definition at line 148 of file ilaenv2stage.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     July 2017
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
*     ..
*
*  =====================================================================
*     ..
*     .. Local Scalars ..
      INTEGER            IISPEC
*     ..
*     .. External Functions ..
      INTEGER            IPARAM2STAGE
      EXTERNAL           iparam2stage
*     ..
*     .. Executable Statements ..
*
      GO TO ( 10, 10, 10, 10, 10 )ispec
*
*     Invalid value for ISPEC
*
      ilaenv2stage = -1
      RETURN
*
   10 CONTINUE
*
*     2stage eigenvalues and SVD or related subroutines.
*
      iispec = 16 + ispec
      ilaenv2stage = iparam2stage( iispec, name, opts,
     $                             n1, n2, n3, n4 )
      RETURN
*
*     End of ILAENV2STAGE
*

iparmq()

integer function iparmq	(	integer	ispec,
		character, dimension( * )	name,
		character, dimension( * )	opts,
		integer	n,
		integer	ilo,
		integer	ihi,
		integer	lwork )

IPARMQ

Download IPARMQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!>      This program sets problem and machine dependent parameters
!>      useful for xHSEQR and related subroutines for eigenvalue
!>      problems. It is called whenever
!>      IPARMQ is called with 12 <= ISPEC <= 16
!> 

Parameters

[in]	ISPEC	!> ISPEC is INTEGER !> ISPEC specifies which tunable parameter IPARMQ should !> return. !> !> ISPEC=12: (INMIN) Matrices of order nmin or less !> are sent directly to xLAHQR, the implicit !> double shift QR algorithm. NMIN must be !> at least 11. !> !> ISPEC=13: (INWIN) Size of the deflation window. !> This is best set greater than or equal to !> the number of simultaneous shifts NS. !> Larger matrices benefit from larger deflation !> windows. !> !> ISPEC=14: (INIBL) Determines when to stop nibbling and !> invest in an (expensive) multi-shift QR sweep. !> If the aggressive early deflation subroutine !> finds LD converged eigenvalues from an order !> NW deflation window and LD > (NW*NIBBLE)/100, !> then the next QR sweep is skipped and early !> deflation is applied immediately to the !> remaining active diagonal block. Setting !> IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a !> multi-shift QR sweep whenever early deflation !> finds a converged eigenvalue. Setting !> IPARMQ(ISPEC=14) greater than or equal to 100 !> prevents TTQRE from skipping a multi-shift !> QR sweep. !> !> ISPEC=15: (NSHFTS) The number of simultaneous shifts in !> a multi-shift QR iteration. !> !> ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the !> following meanings. !> 0: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are not !> accumulated when updating the !> far-from-diagonal matrix entries. !> 1: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are !> accumulated, and matrix-matrix !> multiplication is used to update the !> far-from-diagonal matrix entries. !> 2: During the multi-shift QR/QZ sweep, !> blocked eigenvalue reordering, blocked !> Hessenberg-triangular reduction, !> reflections and/or rotations are !> accumulated, and 2-by-2 block structure !> is exploited during matrix-matrix !> multiplies. !> (If xTRMM is slower than xGEMM, then !> IPARMQ(ISPEC=16)=1 may be more efficient than !> IPARMQ(ISPEC=16)=2 despite the greater level of !> arithmetic work implied by the latter choice.) !> !> ISPEC=17: (ICOST) An estimate of the relative cost of flops !> within the near-the-diagonal shift chase compared !> to flops within the BLAS calls of a QZ sweep. !>
[in]	NAME	!> NAME is CHARACTER string !> Name of the calling subroutine !>
[in]	OPTS	!> OPTS is CHARACTER string !> This is a concatenation of the string arguments to !> TTQRE. !>
[in]	N	!> N is INTEGER !> N is the order of the Hessenberg matrix H. !>
[in]	ILO	!> ILO is INTEGER !>
[in]	IHI	!> IHI is INTEGER !> It is assumed that H is already upper triangular !> in rows and columns 1:ILO-1 and IHI+1:N. !>
[in]	LWORK	!> LWORK is INTEGER !> The amount of workspace available. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>       Little is known about how best to choose these parameters.
!>       It is possible to use different values of the parameters
!>       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
!>
!>       It is probably best to choose different parameters for
!>       different matrices and different parameters at different
!>       times during the iteration, but this has not been
!>       implemented --- yet.
!>
!>
!>       The best choices of most of the parameters depend
!>       in an ill-understood way on the relative execution
!>       rate of xLAQR3 and xLAQR5 and on the nature of each
!>       particular eigenvalue problem.  Experiment may be the
!>       only practical way to determine which choices are most
!>       effective.
!>
!>       Following is a list of default values supplied by IPARMQ.
!>       These defaults may be adjusted in order to attain better
!>       performance in any particular computational environment.
!>
!>       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
!>                        Default: 75. (Must be at least 11.)
!>
!>       IPARMQ(ISPEC=13) Recommended deflation window size.
!>                        This depends on ILO, IHI and NS, the
!>                        number of simultaneous shifts returned
!>                        by IPARMQ(ISPEC=15).  The default for
!>                        (IHI-ILO+1) <= 500 is NS.  The default
!>                        for (IHI-ILO+1) > 500 is 3*NS/2.
!>
!>       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14.
!>
!>       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
!>                        a multi-shift QR iteration.
!>
!>                        If IHI-ILO+1 is ...
!>
!>                        greater than      ...but less    ... the
!>                        or equal to ...      than        default is
!>
!>                                0               30       NS =   2+
!>                               30               60       NS =   4+
!>                               60              150       NS =  10
!>                              150              590       NS =  **
!>                              590             3000       NS =  64
!>                             3000             6000       NS = 128
!>                             6000             infinity   NS = 256
!>
!>                    (+)  By default matrices of this order are
!>                         passed to the implicit double shift routine
!>                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These
!>                         values of NS are used only in case of a rare
!>                         xLAHQR failure.
!>
!>                    (**) The asterisks (**) indicate an ad-hoc
!>                         function increasing from 10 to 64.
!>
!>       IPARMQ(ISPEC=16) Select structured matrix multiply.
!>                        (See ISPEC=16 above for details.)
!>                        Default: 3.
!>
!>       IPARMQ(ISPEC=17) Relative cost heuristic for blocksize selection.
!>                        Expressed as a percentage.
!>                        Default: 10.
!> 

Definition at line 229 of file iparmq.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, ISPEC, LWORK, N
      CHARACTER          NAME*( * ), OPTS*( * )
*
*  ================================================================
*     .. Parameters ..
      INTEGER            INMIN, INWIN, INIBL, ISHFTS, IACC22, ICOST
      parameter( inmin = 12, inwin = 13, inibl = 14,
     $                   ishfts = 15, iacc22 = 16, icost = 17 )
      INTEGER            NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP, RCOST
      parameter( nmin = 75, k22min = 14, kacmin = 14,
     $                   nibble = 14, knwswp = 500, rcost = 10 )
      REAL               TWO
      parameter( two = 2.0 )
*     ..
*     .. Local Scalars ..
      INTEGER            NH, NS
      INTEGER            I, IC, IZ
      CHARACTER          SUBNAM*6
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          log, max, mod, nint, real
*     ..
*     .. Executable Statements ..
      IF( ( ispec.EQ.ishfts ) .OR. ( ispec.EQ.inwin ) .OR.
     $    ( ispec.EQ.iacc22 ) ) THEN
*
*        ==== Set the number simultaneous shifts ====
*
         nh = ihi - ilo + 1
         ns = 2
         IF( nh.GE.30 )
     $      ns = 4
         IF( nh.GE.60 )
     $      ns = 10
         IF( nh.GE.150 )
     $      ns = max( 10, nh / nint( log( real( nh ) ) / log( two ) ) )
         IF( nh.GE.590 )
     $      ns = 64
         IF( nh.GE.3000 )
     $      ns = 128
         IF( nh.GE.6000 )
     $      ns = 256
         ns = max( 2, ns-mod( ns, 2 ) )
      END IF
*
      IF( ispec.EQ.inmin ) THEN
*
*
*        ===== Matrices of order smaller than NMIN get sent
*        .     to xLAHQR, the classic double shift algorithm.
*        .     This must be at least 11. ====
*
         iparmq = nmin
*
      ELSE IF( ispec.EQ.inibl ) THEN
*
*        ==== INIBL: skip a multi-shift qr iteration and
*        .    whenever aggressive early deflation finds
*        .    at least (NIBBLE*(window size)/100) deflations. ====
*
         iparmq = nibble
*
      ELSE IF( ispec.EQ.ishfts ) THEN
*
*        ==== NSHFTS: The number of simultaneous shifts =====
*
         iparmq = ns
*
      ELSE IF( ispec.EQ.inwin ) THEN
*
*        ==== NW: deflation window size.  ====
*
         IF( nh.LE.knwswp ) THEN
            iparmq = ns
         ELSE
            iparmq = 3*ns / 2
         END IF
*
      ELSE IF( ispec.EQ.iacc22 ) THEN
*
*        ==== IACC22: Whether to accumulate reflections
*        .     before updating the far-from-diagonal elements
*        .     and whether to use 2-by-2 block structure while
*        .     doing it.  A small amount of work could be saved
*        .     by making this choice dependent also upon the
*        .     NH=IHI-ILO+1.
*
*
*        Convert NAME to upper case if the first character is lower case.
*
         iparmq = 0
         subnam = name
         ic = ichar( subnam( 1: 1 ) )
         iz = ichar( 'Z' )
         IF( iz.EQ.90 .OR. iz.EQ.122 ) THEN
*
*           ASCII character set
*
            IF( ic.GE.97 .AND. ic.LE.122 ) THEN
               subnam( 1: 1 ) = char( ic-32 )
               DO i = 2, 6
                  ic = ichar( subnam( i: i ) )
                  IF( ic.GE.97 .AND. ic.LE.122 )
     $               subnam( i: i ) = char( ic-32 )
               END DO
            END IF
*
         ELSE IF( iz.EQ.233 .OR. iz.EQ.169 ) THEN
*
*           EBCDIC character set
*
            IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
     $          ( ic.GE.145 .AND. ic.LE.153 ) .OR.
     $          ( ic.GE.162 .AND. ic.LE.169 ) ) THEN
               subnam( 1: 1 ) = char( ic+64 )
               DO i = 2, 6
                  ic = ichar( subnam( i: i ) )
                  IF( ( ic.GE.129 .AND. ic.LE.137 ) .OR.
     $                ( ic.GE.145 .AND. ic.LE.153 ) .OR.
     $                ( ic.GE.162 .AND. ic.LE.169 ) )subnam( i:
     $                i ) = char( ic+64 )
               END DO
            END IF
*
         ELSE IF( iz.EQ.218 .OR. iz.EQ.250 ) THEN
*
*           Prime machines:  ASCII+128
*
            IF( ic.GE.225 .AND. ic.LE.250 ) THEN
               subnam( 1: 1 ) = char( ic-32 )
               DO i = 2, 6
                  ic = ichar( subnam( i: i ) )
                  IF( ic.GE.225 .AND. ic.LE.250 )
     $               subnam( i: i ) = char( ic-32 )
               END DO
            END IF
         END IF
*
         IF( subnam( 2:6 ).EQ.'GGHRD' .OR.
     $       subnam( 2:6 ).EQ.'GGHD3' ) THEN
            iparmq = 1
            IF( nh.GE.k22min )
     $         iparmq = 2
         ELSE IF ( subnam( 4:6 ).EQ.'EXC' ) THEN
            IF( nh.GE.kacmin )
     $         iparmq = 1
            IF( nh.GE.k22min )
     $         iparmq = 2
         ELSE IF ( subnam( 2:6 ).EQ.'HSEQR' .OR.
     $             subnam( 2:5 ).EQ.'LAQR' ) THEN
            IF( ns.GE.kacmin )
     $         iparmq = 1
            IF( ns.GE.k22min )
     $         iparmq = 2
         END IF
*
      ELSE IF( ispec.EQ.icost ) THEN
*
*        === Relative cost of near-the-diagonal chase vs
*            BLAS updates ===
*
         iparmq = rcost
      ELSE
*        ===== invalid value of ispec =====
         iparmq = -1
*
      END IF
*
*     ==== End of IPARMQ ====
*

lsamen()

logical function lsamen	(	integer	n,
		character*( * )	ca,
		character*( * )	cb )

LSAMEN

Download LSAMEN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> LSAMEN  tests if the first N letters of CA are the same as the
!> first N letters of CB, regardless of case.
!> LSAMEN returns .TRUE. if CA and CB are equivalent except for case
!> and .FALSE. otherwise.  LSAMEN also returns .FALSE. if LEN( CA )
!> or LEN( CB ) is less than N.
!> 

Parameters

[in]	N	!> N is INTEGER !> The number of characters in CA and CB to be compared. !>
[in]	CA	!> CA is CHARACTER*(*) !>
[in]	CB	!> CB is CHARACTER*(*) !> CA and CB specify two character strings of length at least N. !> Only the first N characters of each string will be accessed. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 73 of file lsamen.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER*( * )    CA, CB
      INTEGER            N
*     ..
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          len
*     ..
*     .. Executable Statements ..
*
      lsamen = .false.
      IF( len( ca ).LT.n .OR. len( cb ).LT.n )
     $   GO TO 20
*
*     Do for each character in the two strings.
*
      DO 10 i = 1, n
*
*        Test if the characters are equal using LSAME.
*
         IF( .NOT.lsame( ca( i: i ), cb( i: i ) ) )
     $      GO TO 20
*
   10 CONTINUE
      lsamen = .true.
*
   20 CONTINUE
      RETURN
*
*     End of LSAMEN
*

sisnan()

logical function sisnan

(

real, intent(in)

sin

)

SISNAN tests input for NaN.

Download SISNAN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SISNAN returns .TRUE. if its argument is NaN, and .FALSE.
!> otherwise.  To be replaced by the Fortran 2003 intrinsic in the
!> future.
!> 

Parameters

[in]

SIN

!> SIN is REAL !> Input to test for NaN. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 58 of file sisnan.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL, INTENT(IN) :: SIN
*     ..
*
*  =====================================================================
*
*  .. External Functions ..
      LOGICAL SLAISNAN
      EXTERNAL slaisnan
*  ..
*  .. Executable Statements ..
      sisnan = slaisnan(sin,sin)
      RETURN

slabad()

subroutine slabad	(	real	small,
		real	large )

SLABAD

Download SLABAD + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLABAD takes as input the values computed by SLAMCH for underflow and
!> overflow, and returns the square root of each of these values if the
!> log of LARGE is sufficiently large.  This subroutine is intended to
!> identify machines with a large exponent range, such as the Crays, and
!> redefine the underflow and overflow limits to be the square roots of
!> the values computed by SLAMCH.  This subroutine is needed because
!> SLAMCH does not compensate for poor arithmetic in the upper half of
!> the exponent range, as is found on a Cray.
!> 

Parameters

[in,out]	SMALL	!> SMALL is REAL !> On entry, the underflow threshold as computed by SLAMCH. !> On exit, if LOG10(LARGE) is sufficiently large, the square !> root of SMALL, otherwise unchanged. !>
[in,out]	LARGE	!> LARGE is REAL !> On entry, the overflow threshold as computed by SLAMCH. !> On exit, if LOG10(LARGE) is sufficiently large, the square !> root of LARGE, otherwise unchanged. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 73 of file slabad.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               LARGE, SMALL
*     ..
*
*  =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          log10, sqrt
*     ..
*     .. Executable Statements ..
*
*     If it looks like we're on a Cray, take the square root of
*     SMALL and LARGE to avoid overflow and underflow problems.
*
      IF( log10( large ).GT.2000. ) THEN
         small = sqrt( small )
         large = sqrt( large )
      END IF
*
      RETURN
*
*     End of SLABAD
*

slacpy()

subroutine slacpy	(	character	uplo,
		integer	m,
		integer	n,
		real, dimension( lda, * )	a,
		integer	lda,
		real, dimension( ldb, * )	b,
		integer	ldb )

SLACPY copies all or part of one two-dimensional array to another.

Download SLACPY + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLACPY copies all or part of a two-dimensional matrix A to another
!> matrix B.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be copied to B. !> = 'U': Upper triangular part !> = 'L': Lower triangular part !> Otherwise: All of the matrix A !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in]	A	!> A is REAL array, dimension (LDA,N) !> The m by n matrix A. If UPLO = 'U', only the upper triangle !> or trapezoid is accessed; if UPLO = 'L', only the lower !> triangle or trapezoid is accessed. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>
[out]	B	!> B is REAL array, dimension (LDB,N) !> On exit, B = A in the locations specified by UPLO. !>
[in]	LDB	!> LDB is INTEGER !> The leading dimension of the array B. LDB >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 102 of file slacpy.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDB, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( lsame( uplo, 'U' ) ) THEN
         DO 20 j = 1, n
            DO 10 i = 1, min( j, m )
               b( i, j ) = a( i, j )
   10       CONTINUE
   20    CONTINUE
      ELSE IF( lsame( uplo, 'L' ) ) THEN
         DO 40 j = 1, n
            DO 30 i = j, m
               b( i, j ) = a( i, j )
   30       CONTINUE
   40    CONTINUE
      ELSE
         DO 60 j = 1, n
            DO 50 i = 1, m
               b( i, j ) = a( i, j )
   50       CONTINUE
   60    CONTINUE
      END IF
      RETURN
*
*     End of SLACPY
*

slae2()

subroutine slae2	(	real	a,
		real	b,
		real	c,
		real	rt1,
		real	rt2 )

SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.

Download SLAE2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, and RT2
!> is the eigenvalue of smaller absolute value.
!> 

Parameters

[in]	A	!> A is REAL !> The (1,1) element of the 2-by-2 matrix. !>
[in]	B	!> B is REAL !> The (1,2) and (2,1) elements of the 2-by-2 matrix. !>
[in]	C	!> C is REAL !> The (2,2) element of the 2-by-2 matrix. !>
[out]	RT1	!> RT1 is REAL !> The eigenvalue of larger absolute value. !>
[out]	RT2	!> RT2 is REAL !> The eigenvalue of smaller absolute value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> 

Definition at line 101 of file slae2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               A, B, C, RT1, RT2
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      parameter( one = 1.0e0 )
      REAL               TWO
      parameter( two = 2.0e0 )
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               HALF
      parameter( half = 0.5e0 )
*     ..
*     .. Local Scalars ..
      REAL               AB, ACMN, ACMX, ADF, DF, RT, SM, TB
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
*     Compute the eigenvalues
*
      sm = a + c
      df = a - c
      adf = abs( df )
      tb = b + b
      ab = abs( tb )
      IF( abs( a ).GT.abs( c ) ) THEN
         acmx = a
         acmn = c
      ELSE
         acmx = c
         acmn = a
      END IF
      IF( adf.GT.ab ) THEN
         rt = adf*sqrt( one+( ab / adf )**2 )
      ELSE IF( adf.LT.ab ) THEN
         rt = ab*sqrt( one+( adf / ab )**2 )
      ELSE
*
*        Includes case AB=ADF=0
*
         rt = ab*sqrt( two )
      END IF
      IF( sm.LT.zero ) THEN
         rt1 = half*( sm-rt )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE IF( sm.GT.zero ) THEN
         rt1 = half*( sm+rt )
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE
*
*        Includes case RT1 = RT2 = 0
*
         rt1 = half*rt
         rt2 = -half*rt
      END IF
      RETURN
*
*     End of SLAE2
*

slaebz()

subroutine slaebz	(	integer	ijob,
		integer	nitmax,
		integer	n,
		integer	mmax,
		integer	minp,
		integer	nbmin,
		real	abstol,
		real	reltol,
		real	pivmin,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( * )	e2,
		integer, dimension( * )	nval,
		real, dimension( mmax, * )	ab,
		real, dimension( * )	c,
		integer	mout,
		integer, dimension( mmax, * )	nab,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

SLAEBZ computes the number of eigenvalues of a real symmetric tridiagonal matrix which are less than or equal to a given value, and performs other tasks required by the routine sstebz.

Download SLAEBZ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> 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 , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966
!>
!> Note: the arguments are, in general, *not* checked for unreasonable
!> values.
!> 

Parameters

[in]	IJOB	!> IJOB is INTEGER !> Specifies what is to be done: !> = 1: Compute NAB for the initial intervals. !> = 2: Perform bisection iteration to find eigenvalues of T. !> = 3: Perform bisection iteration to invert N(w), i.e., !> to find a point which has a specified number of !> eigenvalues of T to its left. !> Other values will cause SLAEBZ to return with INFO=-1. !>
[in]	NITMAX	!> NITMAX is INTEGER !> The maximum number of of bisection to be !> performed, i.e., an interval of width W will not be made !> smaller than 2^(-NITMAX) * W. If not all intervals !> have converged after NITMAX iterations, then INFO is set !> to the number of non-converged intervals. !>
[in]	N	!> N is INTEGER !> The dimension n of the tridiagonal matrix T. It must be at !> least 1. !>
[in]	MMAX	!> MMAX is INTEGER !> The maximum number of intervals. If more than MMAX intervals !> are generated, then SLAEBZ will quit with INFO=MMAX+1. !>
[in]	MINP	!> MINP is INTEGER !> The initial number of intervals. It may not be greater than !> MMAX. !>
[in]	NBMIN	!> NBMIN is INTEGER !> The smallest number of intervals that should be processed !> using a vector loop. If zero, then only the scalar loop !> will be used. !>
[in]	ABSTOL	!> ABSTOL is REAL !> The minimum (absolute) width of an interval. When an !> interval is narrower than ABSTOL, or than RELTOL times the !> larger (in magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. This must be at least !> zero. !>
[in]	RELTOL	!> RELTOL is REAL !> The minimum relative width of an interval. When an interval !> is narrower than ABSTOL, or than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum absolute value of a in the Sturm !> sequence loop. !> This must be at least max |e(j)**2|*safe_min and at !> least safe_min, where safe_min is at least !> the smallest number that can divide one without overflow. !>
[in]	D	!> D is REAL array, dimension (N) !> The diagonal elements of the tridiagonal matrix T. !>
[in]	E	!> E is REAL array, dimension (N) !> The offdiagonal elements of the tridiagonal matrix T in !> positions 1 through N-1. E(N) is arbitrary. !>
[in]	E2	!> E2 is REAL array, dimension (N) !> The squares of the offdiagonal elements of the tridiagonal !> matrix T. E2(N) is ignored. !>
[in,out]	NVAL	!> NVAL is INTEGER array, dimension (MINP) !> If IJOB=1 or 2, not referenced. !> If IJOB=3, the desired values of N(w). The elements of NVAL !> will be reordered to correspond with the intervals in AB. !> Thus, NVAL(j) on output will not, in general be the same as !> NVAL(j) on input, but it will correspond with the interval !> (AB(j,1),AB(j,2)] on output. !>
[in,out]	AB	!> AB is REAL array, dimension (MMAX,2) !> The endpoints of the intervals. AB(j,1) is a(j), the left !> endpoint of the j-th interval, and AB(j,2) is b(j), the !> right endpoint of the j-th interval. The input intervals !> will, in general, be modified, split, and reordered by the !> calculation. !>
[in,out]	C	!> C is REAL array, dimension (MMAX) !> If IJOB=1, ignored. !> If IJOB=2, workspace. !> If IJOB=3, then on input C(j) should be initialized to the !> first search point in the binary search. !>
[out]	MOUT	!> MOUT is INTEGER !> If IJOB=1, the number of eigenvalues in the intervals. !> If IJOB=2 or 3, the number of intervals output. !> If IJOB=3, MOUT will equal MINP. !>
[in,out]	NAB	!> NAB is INTEGER array, dimension (MMAX,2) !> If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)). !> If IJOB=2, then on input, NAB(i,j) should be set. It must !> satisfy the condition: !> N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)), !> which means that in interval i only eigenvalues !> NAB(i,1)+1,...,NAB(i,2) will be considered. Usually, !> NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with !> IJOB=1. !> On output, NAB(i,j) will contain !> max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of !> the input interval that the output interval !> (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the !> the input values of NAB(k,1) and NAB(k,2). !> If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)), !> unless N(w) > NVAL(i) for all search points w , in which !> case NAB(i,1) will not be modified, i.e., the output !> value will be the same as the input value (modulo !> reorderings -- see NVAL and AB), or unless N(w) < NVAL(i) !> for all search points w , in which case NAB(i,2) will !> not be modified. Normally, NAB should be set to some !> distinctive value(s) before SLAEBZ is called. !>
[out]	WORK	!> WORK is REAL array, dimension (MMAX) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (MMAX) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> = 0: All intervals converged. !> = 1--MMAX: The last INFO intervals did not converge. !> = MMAX+1: More than MMAX intervals were generated. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>      This routine is intended to be called only by other LAPACK
!>  routines, thus the interface is less user-friendly.  It is intended
!>  for two purposes:
!>
!>  (a) finding eigenvalues.  In this case, SLAEBZ should have one or
!>      more initial intervals set up in AB, and SLAEBZ should be called
!>      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.
!>      Intervals with no eigenvalues would usually be thrown out at
!>      this point.  Also, if not all the eigenvalues in an interval i
!>      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
!>      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
!>      eigenvalue.  SLAEBZ is then called with IJOB=2 and MMAX
!>      no smaller than the value of MOUT returned by the call with
!>      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1
!>      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
!>      tolerance specified by ABSTOL and RELTOL.
!>
!>  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
!>      In this case, start with a Gershgorin interval  (a,b).  Set up
!>      AB to contain 2 search intervals, both initially (a,b).  One
!>      NVAL element should contain  f-1  and the other should contain  l
!>      , while C should contain a and b, resp.  NAB(i,1) should be -1
!>      and NAB(i,2) should be N+1, to flag an error if the desired
!>      interval does not lie in (a,b).  SLAEBZ is then called with
!>      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --
!>      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
!>      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
!>      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and
!>      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and
!>      w(l-r)=...=w(l+k) are handled similarly.
!> 

Definition at line 316 of file slaebz.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
      REAL               ABSTOL, PIVMIN, RELTOL
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * ), NAB( MMAX, * ), NVAL( * )
      REAL               AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, TWO, HALF
      parameter( zero = 0.0e0, two = 2.0e0,
     $                   half = 1.0e0 / two )
*     ..
*     .. Local Scalars ..
      INTEGER            ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
     $                   KLNEW
      REAL               TMP1, TMP2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. Executable Statements ..
*
*     Check for Errors
*
      info = 0
      IF( ijob.LT.1 .OR. ijob.GT.3 ) THEN
         info = -1
         RETURN
      END IF
*
*     Initialize NAB
*
      IF( ijob.EQ.1 ) THEN
*
*        Compute the number of eigenvalues in the initial intervals.
*
         mout = 0
         DO 30 ji = 1, minp
            DO 20 jp = 1, 2
               tmp1 = d( 1 ) - ab( ji, jp )
               IF( abs( tmp1 ).LT.pivmin )
     $            tmp1 = -pivmin
               nab( ji, jp ) = 0
               IF( tmp1.LE.zero )
     $            nab( ji, jp ) = 1
*
               DO 10 j = 2, n
                  tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp )
                  IF( abs( tmp1 ).LT.pivmin )
     $               tmp1 = -pivmin
                  IF( tmp1.LE.zero )
     $               nab( ji, jp ) = nab( ji, jp ) + 1
   10          CONTINUE
   20       CONTINUE
            mout = mout + nab( ji, 2 ) - nab( ji, 1 )
   30    CONTINUE
         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
      kl = minp
*
*     If IJOB=2, initialize C.
*     If IJOB=3, use the user-supplied starting point.
*
      IF( ijob.EQ.2 ) THEN
         DO 40 ji = 1, minp
            c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) )
   40    CONTINUE
      END IF
*
*     Iteration loop
*
      DO 130 jit = 1, nitmax
*
*        Loop over intervals
*
         IF( kl-kf+1.GE.nbmin .AND. nbmin.GT.0 ) THEN
*
*           Begin of Parallel Version of the loop
*
            DO 60 ji = kf, kl
*
*              Compute N(c), the number of eigenvalues less than c
*
               work( ji ) = d( 1 ) - c( ji )
               iwork( ji ) = 0
               IF( work( ji ).LE.pivmin ) THEN
                  iwork( ji ) = 1
                  work( ji ) = min( work( ji ), -pivmin )
               END IF
*
               DO 50 j = 2, n
                  work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji )
                  IF( work( ji ).LE.pivmin ) THEN
                     iwork( ji ) = iwork( ji ) + 1
                     work( ji ) = min( work( ji ), -pivmin )
                  END IF
   50          CONTINUE
   60       CONTINUE
*
            IF( ijob.LE.2 ) THEN
*
*              IJOB=2: Choose all intervals containing eigenvalues.
*
               klnew = kl
               DO 70 ji = kf, kl
*
*                 Insure that N(w) is monotone
*
                  iwork( ji ) = min( nab( ji, 2 ),
     $                          max( nab( ji, 1 ), iwork( ji ) ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( iwork( ji ).EQ.nab( ji, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     ab( ji, 2 ) = c( ji )
*
                  ELSE IF( iwork( ji ).EQ.nab( ji, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     ab( ji, 1 ) = c( ji )
                  ELSE
                     klnew = klnew + 1
                     IF( klnew.LE.mmax ) THEN
*
*                       Eigenvalue in both intervals -- add upper to
*                       queue.
*
                        ab( klnew, 2 ) = ab( ji, 2 )
                        nab( klnew, 2 ) = nab( ji, 2 )
                        ab( klnew, 1 ) = c( ji )
                        nab( klnew, 1 ) = iwork( ji )
                        ab( ji, 2 ) = c( ji )
                        nab( ji, 2 ) = iwork( ji )
                     ELSE
                        info = mmax + 1
                     END IF
                  END IF
   70          CONTINUE
               IF( info.NE.0 )
     $            RETURN
               kl = klnew
            ELSE
*
*              IJOB=3: Binary search.  Keep only the interval containing
*                      w   s.t. N(w) = NVAL
*
               DO 80 ji = kf, kl
                  IF( iwork( ji ).LE.nval( ji ) ) THEN
                     ab( ji, 1 ) = c( ji )
                     nab( ji, 1 ) = iwork( ji )
                  END IF
                  IF( iwork( ji ).GE.nval( ji ) ) THEN
                     ab( ji, 2 ) = c( ji )
                     nab( ji, 2 ) = iwork( ji )
                  END IF
   80          CONTINUE
            END IF
*
         ELSE
*
*           End of Parallel Version of the loop
*
*           Begin of Serial Version of the loop
*
            klnew = kl
            DO 100 ji = kf, kl
*
*              Compute N(w), the number of eigenvalues less than w
*
               tmp1 = c( ji )
               tmp2 = d( 1 ) - tmp1
               itmp1 = 0
               IF( tmp2.LE.pivmin ) THEN
                  itmp1 = 1
                  tmp2 = min( tmp2, -pivmin )
               END IF
*
               DO 90 j = 2, n
                  tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1
                  IF( tmp2.LE.pivmin ) THEN
                     itmp1 = itmp1 + 1
                     tmp2 = min( tmp2, -pivmin )
                  END IF
   90          CONTINUE
*
               IF( ijob.LE.2 ) THEN
*
*                 IJOB=2: Choose all intervals containing eigenvalues.
*
*                 Insure that N(w) is monotone
*
                  itmp1 = min( nab( ji, 2 ),
     $                    max( nab( ji, 1 ), itmp1 ) )
*
*                 Update the Queue -- add intervals if both halves
*                 contain eigenvalues.
*
                  IF( itmp1.EQ.nab( ji, 2 ) ) THEN
*
*                    No eigenvalue in the upper interval:
*                    just use the lower interval.
*
                     ab( ji, 2 ) = tmp1
*
                  ELSE IF( itmp1.EQ.nab( ji, 1 ) ) THEN
*
*                    No eigenvalue in the lower interval:
*                    just use the upper interval.
*
                     ab( ji, 1 ) = tmp1
                  ELSE IF( klnew.LT.mmax ) THEN
*
*                    Eigenvalue in both intervals -- add upper to queue.
*
                     klnew = klnew + 1
                     ab( klnew, 2 ) = ab( ji, 2 )
                     nab( klnew, 2 ) = nab( ji, 2 )
                     ab( klnew, 1 ) = tmp1
                     nab( klnew, 1 ) = itmp1
                     ab( ji, 2 ) = tmp1
                     nab( ji, 2 ) = itmp1
                  ELSE
                     info = mmax + 1
                     RETURN
                  END IF
               ELSE
*
*                 IJOB=3: Binary search.  Keep only the interval
*                         containing  w  s.t. N(w) = NVAL
*
                  IF( itmp1.LE.nval( ji ) ) THEN
                     ab( ji, 1 ) = tmp1
                     nab( ji, 1 ) = itmp1
                  END IF
                  IF( itmp1.GE.nval( ji ) ) THEN
                     ab( ji, 2 ) = tmp1
                     nab( ji, 2 ) = itmp1
                  END IF
               END IF
  100       CONTINUE
            kl = klnew
*
         END IF
*
*        Check for convergence
*
         kfnew = kf
         DO 110 ji = kf, kl
            tmp1 = abs( ab( ji, 2 )-ab( ji, 1 ) )
            tmp2 = max( abs( ab( ji, 2 ) ), abs( ab( ji, 1 ) ) )
            IF( tmp1.LT.max( abstol, pivmin, reltol*tmp2 ) .OR.
     $          nab( ji, 1 ).GE.nab( ji, 2 ) ) THEN
*
*              Converged -- Swap with position KFNEW,
*                           then increment KFNEW
*
               IF( ji.GT.kfnew ) THEN
                  tmp1 = ab( ji, 1 )
                  tmp2 = ab( ji, 2 )
                  itmp1 = nab( ji, 1 )
                  itmp2 = nab( ji, 2 )
                  ab( ji, 1 ) = ab( kfnew, 1 )
                  ab( ji, 2 ) = ab( kfnew, 2 )
                  nab( ji, 1 ) = nab( kfnew, 1 )
                  nab( ji, 2 ) = nab( kfnew, 2 )
                  ab( kfnew, 1 ) = tmp1
                  ab( kfnew, 2 ) = tmp2
                  nab( kfnew, 1 ) = itmp1
                  nab( kfnew, 2 ) = itmp2
                  IF( ijob.EQ.3 ) THEN
                     itmp1 = nval( ji )
                     nval( ji ) = nval( kfnew )
                     nval( kfnew ) = itmp1
                  END IF
               END IF
               kfnew = kfnew + 1
            END IF
  110    CONTINUE
         kf = kfnew
*
*        Choose Midpoints
*
         DO 120 ji = kf, kl
            c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) )
  120    CONTINUE
*
*        If no more intervals to refine, quit.
*
         IF( kf.GT.kl )
     $      GO TO 140
  130 CONTINUE
*
*     Converged
*
  140 CONTINUE
      info = max( kl+1-kf, 0 )
      mout = kl
*
      RETURN
*
*     End of SLAEBZ
*

slaev2()

subroutine slaev2	(	real	a,
		real	b,
		real	c,
		real	rt1,
		real	rt2,
		real	cs1,
		real	sn1 )

SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.

Download SLAEV2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
!>    [  A   B  ]
!>    [  B   C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
!> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
!> eigenvector for RT1, giving the decomposition
!>
!>    [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
!>    [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
!> 

Parameters

[in]	A	!> A is REAL !> The (1,1) element of the 2-by-2 matrix. !>
[in]	B	!> B is REAL !> The (1,2) element and the conjugate of the (2,1) element of !> the 2-by-2 matrix. !>
[in]	C	!> C is REAL !> The (2,2) element of the 2-by-2 matrix. !>
[out]	RT1	!> RT1 is REAL !> The eigenvalue of larger absolute value. !>
[out]	RT2	!> RT2 is REAL !> The eigenvalue of smaller absolute value. !>
[out]	CS1	!> CS1 is REAL !>
[out]	SN1	!> SN1 is REAL !> The vector (CS1, SN1) is a unit right eigenvector for RT1. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!> 

Definition at line 119 of file slaev2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               A, B, C, CS1, RT1, RT2, SN1
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      parameter( one = 1.0e0 )
      REAL               TWO
      parameter( two = 2.0e0 )
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               HALF
      parameter( half = 0.5e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            SGN1, SGN2
      REAL               AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
     $                   TB, TN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
*     Compute the eigenvalues
*
      sm = a + c
      df = a - c
      adf = abs( df )
      tb = b + b
      ab = abs( tb )
      IF( abs( a ).GT.abs( c ) ) THEN
         acmx = a
         acmn = c
      ELSE
         acmx = c
         acmn = a
      END IF
      IF( adf.GT.ab ) THEN
         rt = adf*sqrt( one+( ab / adf )**2 )
      ELSE IF( adf.LT.ab ) THEN
         rt = ab*sqrt( one+( adf / ab )**2 )
      ELSE
*
*        Includes case AB=ADF=0
*
         rt = ab*sqrt( two )
      END IF
      IF( sm.LT.zero ) THEN
         rt1 = half*( sm-rt )
         sgn1 = -1
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE IF( sm.GT.zero ) THEN
         rt1 = half*( sm+rt )
         sgn1 = 1
*
*        Order of execution important.
*        To get fully accurate smaller eigenvalue,
*        next line needs to be executed in higher precision.
*
         rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b
      ELSE
*
*        Includes case RT1 = RT2 = 0
*
         rt1 = half*rt
         rt2 = -half*rt
         sgn1 = 1
      END IF
*
*     Compute the eigenvector
*
      IF( df.GE.zero ) THEN
         cs = df + rt
         sgn2 = 1
      ELSE
         cs = df - rt
         sgn2 = -1
      END IF
      acs = abs( cs )
      IF( acs.GT.ab ) THEN
         ct = -tb / cs
         sn1 = one / sqrt( one+ct*ct )
         cs1 = ct*sn1
      ELSE
         IF( ab.EQ.zero ) THEN
            cs1 = one
            sn1 = zero
         ELSE
            tn = -cs / tb
            cs1 = one / sqrt( one+tn*tn )
            sn1 = tn*cs1
         END IF
      END IF
      IF( sgn1.EQ.sgn2 ) THEN
         tn = cs1
         cs1 = -sn1
         sn1 = tn
      END IF
      RETURN
*
*     End of SLAEV2
*

slag2d()

subroutine slag2d	(	integer	m,
		integer	n,
		real, dimension( ldsa, * )	sa,
		integer	ldsa,
		double precision, dimension( lda, * )	a,
		integer	lda,
		integer	info )

SLAG2D converts a single precision matrix to a double precision matrix.

Download SLAG2D + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE
!> PRECISION matrix, A.
!>
!> Note that while it is possible to overflow while converting
!> from double to single, it is not possible to overflow when
!> converting from single to double.
!>
!> This is an auxiliary routine so there is no argument checking.
!> 

Parameters

[in]	M	!> M is INTEGER !> The number of lines of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in]	SA	!> SA is REAL array, dimension (LDSA,N) !> On entry, the M-by-N coefficient matrix SA. !>
[in]	LDSA	!> LDSA is INTEGER !> The leading dimension of the array SA. LDSA >= max(1,M). !>
[out]	A	!> A is DOUBLE PRECISION array, dimension (LDA,N) !> On exit, the M-by-N coefficient matrix A. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 103 of file slag2d.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDSA, M, N
*     ..
*     .. Array Arguments ..
      REAL               SA( LDSA, * )
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. Executable Statements ..
*
      info = 0
      DO 20 j = 1, n
         DO 10 i = 1, m
            a( i, j ) = sa( i, j )
   10    CONTINUE
   20 CONTINUE
      RETURN
*
*     End of SLAG2D
*

slagts()

subroutine slagts	(	integer	job,
		integer	n,
		real, dimension( * )	a,
		real, dimension( * )	b,
		real, dimension( * )	c,
		real, dimension( * )	d,
		integer, dimension( * )	in,
		real, dimension( * )	y,
		real	tol,
		integer	info )

SLAGTS solves the system of equations (T-λI)x = y or (T-λI)Tx = y,where T is a general tridiagonal matrix and λ a scalar, using the LU factorization computed by slagtf.

Download SLAGTS + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAGTS may be used to solve one of the systems of equations
!>
!>    (T - lambda*I)*x = y   or   (T - lambda*I)**T*x = y,
!>
!> where T is an n by n tridiagonal matrix, for x, following the
!> factorization of (T - lambda*I) as
!>
!>    (T - lambda*I) = P*L*U ,
!>
!> by routine SLAGTF. The choice of equation to be solved is
!> controlled by the argument JOB, and in each case there is an option
!> to perturb zero or very small diagonal elements of U, this option
!> being intended for use in applications such as inverse iteration.
!> 

Parameters

[in]	JOB	!> JOB is INTEGER !> Specifies the job to be performed by SLAGTS as follows: !> = 1: The equations (T - lambda*I)x = y are to be solved, !> but diagonal elements of U are not to be perturbed. !> = -1: The equations (T - lambda*I)x = y are to be solved !> and, if overflow would otherwise occur, the diagonal !> elements of U are to be perturbed. See argument TOL !> below. !> = 2: The equations (T - lambda*I)**Tx = y are to be solved, !> but diagonal elements of U are not to be perturbed. !> = -2: The equations (T - lambda*I)**Tx = y are to be solved !> and, if overflow would otherwise occur, the diagonal !> elements of U are to be perturbed. See argument TOL !> below. !>
[in]	N	!> N is INTEGER !> The order of the matrix T. !>
[in]	A	!> A is REAL array, dimension (N) !> On entry, A must contain the diagonal elements of U as !> returned from SLAGTF. !>
[in]	B	!> B is REAL array, dimension (N-1) !> On entry, B must contain the first super-diagonal elements of !> U as returned from SLAGTF. !>
[in]	C	!> C is REAL array, dimension (N-1) !> On entry, C must contain the sub-diagonal elements of L as !> returned from SLAGTF. !>
[in]	D	!> D is REAL array, dimension (N-2) !> On entry, D must contain the second super-diagonal elements !> of U as returned from SLAGTF. !>
[in]	IN	!> IN is INTEGER array, dimension (N) !> On entry, IN must contain details of the matrix P as returned !> from SLAGTF. !>
[in,out]	Y	!> Y is REAL array, dimension (N) !> On entry, the right hand side vector y. !> On exit, Y is overwritten by the solution vector x. !>
[in,out]	TOL	!> TOL is REAL !> On entry, with JOB < 0, TOL should be the minimum !> perturbation to be made to very small diagonal elements of U. !> TOL should normally be chosen as about eps*norm(U), where eps !> is the relative machine precision, but if TOL is supplied as !> non-positive, then it is reset to eps*max( abs( u(i,j) ) ). !> If JOB > 0 then TOL is not referenced. !> !> On exit, TOL is changed as described above, only if TOL is !> non-positive on entry. Otherwise TOL is unchanged. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: overflow would occur when computing the INFO(th) !> element of the solution vector x. This can only occur !> when JOB is supplied as positive and either means !> that a diagonal element of U is very small, or that !> the elements of the right-hand side vector y are very !> large. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 160 of file slagts.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, JOB, N
      REAL               TOL
*     ..
*     .. Array Arguments ..
      INTEGER            IN( * )
      REAL               A( * ), B( * ), C( * ), D( * ), Y( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            K
      REAL               ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sign
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Executable Statements ..
*
      info = 0
      IF( ( abs( job ).GT.2 ) .OR. ( job.EQ.0 ) ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLAGTS', -info )
         RETURN
      END IF
*
      IF( n.EQ.0 )
     $   RETURN
*
      eps = slamch( 'Epsilon' )
      sfmin = slamch( 'Safe minimum' )
      bignum = one / sfmin
*
      IF( job.LT.0 ) THEN
         IF( tol.LE.zero ) THEN
            tol = abs( a( 1 ) )
            IF( n.GT.1 )
     $         tol = max( tol, abs( a( 2 ) ), abs( b( 1 ) ) )
            DO 10 k = 3, n
               tol = max( tol, abs( a( k ) ), abs( b( k-1 ) ),
     $               abs( d( k-2 ) ) )
   10       CONTINUE
            tol = tol*eps
            IF( tol.EQ.zero )
     $         tol = eps
         END IF
      END IF
*
      IF( abs( job ).EQ.1 ) THEN
         DO 20 k = 2, n
            IF( in( k-1 ).EQ.0 ) THEN
               y( k ) = y( k ) - c( k-1 )*y( k-1 )
            ELSE
               temp = y( k-1 )
               y( k-1 ) = y( k )
               y( k ) = temp - c( k-1 )*y( k )
            END IF
   20    CONTINUE
         IF( job.EQ.1 ) THEN
            DO 30 k = n, 1, -1
               IF( k.LE.n-2 ) THEN
                  temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 )
               ELSE IF( k.EQ.n-1 ) THEN
                  temp = y( k ) - b( k )*y( k+1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     info = k
                     RETURN
                  END IF
               END IF
               y( k ) = temp / ak
   30       CONTINUE
         ELSE
            DO 50 k = n, 1, -1
               IF( k.LE.n-2 ) THEN
                  temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 )
               ELSE IF( k.EQ.n-1 ) THEN
                  temp = y( k ) - b( k )*y( k+1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               pert = sign( tol, ak )
   40          CONTINUE
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        ak = ak + pert
                        pert = 2*pert
                        GO TO 40
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     ak = ak + pert
                     pert = 2*pert
                     GO TO 40
                  END IF
               END IF
               y( k ) = temp / ak
   50       CONTINUE
         END IF
      ELSE
*
*        Come to here if  JOB = 2 or -2
*
         IF( job.EQ.2 ) THEN
            DO 60 k = 1, n
               IF( k.GE.3 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 )
               ELSE IF( k.EQ.2 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        info = k
                        RETURN
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     info = k
                     RETURN
                  END IF
               END IF
               y( k ) = temp / ak
   60       CONTINUE
         ELSE
            DO 80 k = 1, n
               IF( k.GE.3 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 )
               ELSE IF( k.EQ.2 ) THEN
                  temp = y( k ) - b( k-1 )*y( k-1 )
               ELSE
                  temp = y( k )
               END IF
               ak = a( k )
               pert = sign( tol, ak )
   70          CONTINUE
               absak = abs( ak )
               IF( absak.LT.one ) THEN
                  IF( absak.LT.sfmin ) THEN
                     IF( absak.EQ.zero .OR. abs( temp )*sfmin.GT.absak )
     $                    THEN
                        ak = ak + pert
                        pert = 2*pert
                        GO TO 70
                     ELSE
                        temp = temp*bignum
                        ak = ak*bignum
                     END IF
                  ELSE IF( abs( temp ).GT.absak*bignum ) THEN
                     ak = ak + pert
                     pert = 2*pert
                     GO TO 70
                  END IF
               END IF
               y( k ) = temp / ak
   80       CONTINUE
         END IF
*
         DO 90 k = n, 2, -1
            IF( in( k-1 ).EQ.0 ) THEN
               y( k-1 ) = y( k-1 ) - c( k-1 )*y( k )
            ELSE
               temp = y( k-1 )
               y( k-1 ) = y( k )
               y( k ) = temp - c( k-1 )*y( k )
            END IF
   90    CONTINUE
      END IF
*
*     End of SLAGTS
*

slaisnan()

logical function slaisnan	(	real, intent(in)	sin1,
		real, intent(in)	sin2 )

SLAISNAN tests input for NaN by comparing two arguments for inequality.

Download SLAISNAN + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This routine is not for general use.  It exists solely to avoid
!> over-optimization in SISNAN.
!>
!> SLAISNAN checks for NaNs by comparing its two arguments for
!> inequality.  NaN is the only floating-point value where NaN != NaN
!> returns .TRUE.  To check for NaNs, pass the same variable as both
!> arguments.
!>
!> A compiler must assume that the two arguments are
!> not the same variable, and the test will not be optimized away.
!> Interprocedural or whole-program optimization may delete this
!> test.  The ISNAN functions will be replaced by the correct
!> Fortran 03 intrinsic once the intrinsic is widely available.
!> 

Parameters

[in]	SIN1	!> SIN1 is REAL !>
[in]	SIN2	!> SIN2 is REAL !> Two numbers to compare for inequality. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 73 of file slaisnan.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL, INTENT(IN) :: SIN1, SIN2
*     ..
*
*  =====================================================================
*
*  .. Executable Statements ..
      slaisnan = (sin1.NE.sin2)
      RETURN

slaneg()

integer function slaneg	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	lld,
		real	sigma,
		real	pivmin,
		integer	r )

SLANEG computes the Sturm count.

Download SLANEG + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> 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,  SIAM Journal on
!>   Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624
!>   (Tech report version in LAWN 172 with the same title.)
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is REAL array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	LLD	!> LLD is REAL array, dimension (N-1) !> The (N-1) elements L(i)*L(i)*D(i). !>
[in]	SIGMA	!> SIGMA is REAL !> Shift amount in T - sigma I = L D L^T. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot in the Sturm sequence. May be used !> when zero pivots are encountered on non-IEEE-754 !> architectures. !>
[in]	R	!> R is INTEGER !> The twist index for the twisted factorization that is used !> for the negcount. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA
Jason Riedy, University of California, Berkeley, USA

Definition at line 117 of file slaneg.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N, R
      REAL               PIVMIN, SIGMA
*     ..
*     .. Array Arguments ..
      REAL               D( * ), LLD( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e0, one = 1.0e0 )
*     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.
      INTEGER BLKLEN
      parameter( blklen = 128 )
*     ..
*     .. Local Scalars ..
      INTEGER            BJ, J, NEG1, NEG2, NEGCNT
      REAL               BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
      LOGICAL SAWNAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC min, max
*     ..
*     .. External Functions ..
      LOGICAL SISNAN
      EXTERNAL sisnan
*     ..
*     .. Executable Statements ..
 
      negcnt = 0
 
*     I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
      t = -sigma
      DO 210 bj = 1, r-1, blklen
         neg1 = 0
         bsav = t
         DO 21 j = bj, min(bj+blklen-1, r-1)
            dplus = d( j ) + t
            IF( dplus.LT.zero ) neg1 = neg1 + 1
            tmp = t / dplus
            t = tmp * lld( j ) - sigma
 21      CONTINUE
         sawnan = 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
            t = bsav
            DO 22 j = bj, min(bj+blklen-1, r-1)
               dplus = d( j ) + t
               IF( dplus.LT.zero ) neg1 = neg1 + 1
               tmp = t / dplus
               IF (sisnan(tmp)) tmp = one
               t = tmp * lld(j) - sigma
 22         CONTINUE
         END IF
         negcnt = negcnt + neg1
 210  CONTINUE
*
*     II) lower part: L D L^T - SIGMA I = U- D- U-^T
      p = d( n ) - sigma
      DO 230 bj = n-1, r, -blklen
         neg2 = 0
         bsav = p
         DO 23 j = bj, max(bj-blklen+1, r), -1
            dminus = lld( j ) + p
            IF( dminus.LT.zero ) neg2 = neg2 + 1
            tmp = p / dminus
            p = tmp * d( j ) - sigma
 23      CONTINUE
         sawnan = sisnan( p )
*     As above, run a slower version that substitutes 1 for Inf/Inf.
*
         IF( sawnan ) THEN
            neg2 = 0
            p = bsav
            DO 24 j = bj, max(bj-blklen+1, r), -1
               dminus = lld( j ) + p
               IF( dminus.LT.zero ) neg2 = neg2 + 1
               tmp = p / dminus
               IF (sisnan(tmp)) tmp = one
               p = tmp * d(j) - sigma
 24         CONTINUE
         END IF
         negcnt = negcnt + neg2
 230  CONTINUE
*
*     III) Twist index
*       T was shifted by SIGMA initially.
      gamma = (t + sigma) + p
      IF( gamma.LT.zero ) negcnt = negcnt+1
 
      slaneg = negcnt

slanst()

real function slanst	(	character	norm,
		integer	n,
		real, dimension( * )	d,
		real, dimension( * )	e )

SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric tridiagonal matrix.

Download SLANST + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLANST  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> real symmetric tridiagonal matrix A.
!> 

Returns

SLANST

!>
!>    SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!> 

Parameters

[in]	NORM	!> NORM is CHARACTER*1 !> Specifies the value to be returned in SLANST as described !> above. !>
[in]	N	!> N is INTEGER !> The order of the matrix A. N >= 0. When N = 0, SLANST is !> set to zero. !>
[in]	D	!> D is REAL array, dimension (N) !> The diagonal elements of A. !>
[in]	E	!> E is REAL array, dimension (N-1) !> The (n-1) sub-diagonal or super-diagonal elements of A. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 99 of file slanst.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               ANORM, SCALE, SUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, SISNAN
      EXTERNAL           lsame, sisnan
*     ..
*     .. External Subroutines ..
      EXTERNAL           slassq
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
      IF( n.LE.0 ) THEN
         anorm = zero
      ELSE IF( lsame( norm, 'M' ) ) THEN
*
*        Find max(abs(A(i,j))).
*
         anorm = abs( d( n ) )
         DO 10 i = 1, n - 1
            sum = abs( d( i ) )
            IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
            sum = abs( e( i ) )
            IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
   10    CONTINUE
      ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' .OR.
     $         lsame( norm, 'I' ) ) THEN
*
*        Find norm1(A).
*
         IF( n.EQ.1 ) THEN
            anorm = abs( d( 1 ) )
         ELSE
            anorm = abs( d( 1 ) )+abs( e( 1 ) )
            sum = abs( e( n-1 ) )+abs( d( n ) )
            IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
            DO 20 i = 2, n - 1
               sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
               IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
   20       CONTINUE
         END IF
      ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
*
*        Find normF(A).
*
         scale = zero
         sum = one
         IF( n.GT.1 ) THEN
            CALL slassq( n-1, e, 1, scale, sum )
            sum = 2*sum
         END IF
         CALL slassq( n, d, 1, scale, sum )
         anorm = scale*sqrt( sum )
      END IF
*
      slanst = anorm
      RETURN
*
*     End of SLANST
*

slapy2()

real function slapy2	(	real	x,
		real	y )

SLAPY2 returns sqrt(x2+y2).

Download SLAPY2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
!> overflow and unnecessary underflow.
!> 

Parameters

[in]	X	!> X is REAL !>
[in]	Y	!> Y is REAL !> X and Y specify the values x and y. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 62 of file slapy2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               X, Y
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               ONE
      parameter( one = 1.0e0 )
*     ..
*     .. Local Scalars ..
      REAL               W, XABS, YABS, Z, HUGEVAL
      LOGICAL            X_IS_NAN, Y_IS_NAN
*     ..
*     .. External Functions ..
      LOGICAL            SISNAN
      EXTERNAL           sisnan
*     ..
*     .. External Subroutines ..
      REAL               SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. Executable Statements ..
*
      x_is_nan = sisnan( x )
      y_is_nan = sisnan( y )
      IF ( x_is_nan ) slapy2 = x
      IF ( y_is_nan ) slapy2 = y
      hugeval = slamch( 'Overflow' )
*
      IF ( .NOT.( x_is_nan.OR.y_is_nan ) ) THEN
         xabs = abs( x )
         yabs = abs( y )
         w = max( xabs, yabs )
         z = min( xabs, yabs )
         IF( z.EQ.zero .OR. w.GT.hugeval ) THEN
            slapy2 = w
         ELSE
            slapy2 = w*sqrt( one+( z / w )**2 )
         END IF
      END IF
      RETURN
*
*     End of SLAPY2
*

slapy3()

real function slapy3	(	real	x,
		real	y,
		real	z )

SLAPY3 returns sqrt(x2+y2+z2).

Download SLAPY3 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
!> unnecessary overflow and unnecessary underflow.
!> 

Parameters

[in]	X	!> X is REAL !>
[in]	Y	!> Y is REAL !>
[in]	Z	!> Z is REAL !> X, Y and Z specify the values x, y and z. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 67 of file slapy3.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               X, Y, Z
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      REAL               W, XABS, YABS, ZABS, HUGEVAL
*     ..
*     .. External Subroutines ..
      REAL               SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sqrt
*     ..
*     .. Executable Statements ..
*
      hugeval = slamch( 'Overflow' )
      xabs = abs( x )
      yabs = abs( y )
      zabs = abs( z )
      w = max( xabs, yabs, zabs )
      IF( w.EQ.zero .OR. w.GT.hugeval ) THEN
*     W can be zero for max(0,nan,0)
*     adding all three entries together will make sure
*     NaN will not disappear.
         slapy3 =  xabs + yabs + zabs
      ELSE
         slapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+
     $            ( zabs / w )**2 )
      END IF
      RETURN
*
*     End of SLAPY3
*

slarnv()

subroutine slarnv	(	integer	idist,
		integer, dimension( 4 )	iseed,
		integer	n,
		real, dimension( * )	x )

SLARNV returns a vector of random numbers from a uniform or normal distribution.

Download SLARNV + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLARNV returns a vector of n random real numbers from a uniform or
!> normal distribution.
!> 

Parameters

[in]	IDIST	!> IDIST is INTEGER !> Specifies the distribution of the random numbers: !> = 1: uniform (0,1) !> = 2: uniform (-1,1) !> = 3: normal (0,1) !>
[in,out]	ISEED	!> ISEED is INTEGER array, dimension (4) !> On entry, the seed of the random number generator; the array !> elements must be between 0 and 4095, and ISEED(4) must be !> odd. !> On exit, the seed is updated. !>
[in]	N	!> N is INTEGER !> The number of random numbers to be generated. !>
[out]	X	!> X is REAL array, dimension (N) !> The generated random numbers. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  This routine calls the auxiliary routine SLARUV to generate random
!>  real numbers from a uniform (0,1) distribution, in batches of up to
!>  128 using vectorisable code. The Box-Muller method is used to
!>  transform numbers from a uniform to a normal distribution.
!> 

Definition at line 96 of file slarnv.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IDIST, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               X( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO
      parameter( one = 1.0e+0, two = 2.0e+0 )
      INTEGER            LV
      parameter( lv = 128 )
      REAL               TWOPI
      parameter( twopi = 6.28318530717958647692528676655900576839e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IL, IL2, IV
*     ..
*     .. Local Arrays ..
      REAL               U( LV )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          cos, log, min, sqrt
*     ..
*     .. External Subroutines ..
      EXTERNAL           slaruv
*     ..
*     .. Executable Statements ..
*
      DO 40 iv = 1, n, lv / 2
         il = min( lv / 2, n-iv+1 )
         IF( idist.EQ.3 ) THEN
            il2 = 2*il
         ELSE
            il2 = il
         END IF
*
*        Call SLARUV to generate IL2 numbers from a uniform (0,1)
*        distribution (IL2 <= LV)
*
         CALL slaruv( iseed, il2, u )
*
         IF( idist.EQ.1 ) THEN
*
*           Copy generated numbers
*
            DO 10 i = 1, il
               x( iv+i-1 ) = u( i )
   10       CONTINUE
         ELSE IF( idist.EQ.2 ) THEN
*
*           Convert generated numbers to uniform (-1,1) distribution
*
            DO 20 i = 1, il
               x( iv+i-1 ) = two*u( i ) - one
   20       CONTINUE
         ELSE IF( idist.EQ.3 ) THEN
*
*           Convert generated numbers to normal (0,1) distribution
*
            DO 30 i = 1, il
               x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*
     $                       cos( twopi*u( 2*i ) )
   30       CONTINUE
         END IF
   40 CONTINUE
      RETURN
*
*     End of SLARNV
*

slarra()

subroutine slarra	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( * )	e2,
		real	spltol,
		real	tnrm,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	info )

SLARRA computes the splitting points with the specified threshold.

Download SLARRA + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Compute the splitting points with threshold SPLTOL.
!> SLARRA sets any  off-diagonal elements to zero.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	D	!> D is REAL array, dimension (N) !> On entry, the N diagonal elements of the tridiagonal !> matrix T. !>
[in,out]	E	!> E is REAL array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) need not be set. !> On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, !> are set to zero, the other entries of E are untouched. !>
[in,out]	E2	!> E2 is REAL array, dimension (N) !> On entry, the first (N-1) entries contain the SQUARES of the !> subdiagonal elements of the tridiagonal matrix T; !> E2(N) need not be set. !> On exit, the entries E2( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, have been set to zero !>
[in]	SPLTOL	!> SPLTOL is REAL !> The threshold for splitting. Two criteria can be used: !> SPLTOL<0 : criterion based on absolute off-diagonal value !> SPLTOL>0 : criterion that preserves relative accuracy !>
[in]	TNRM	!> TNRM is REAL !> The norm of the matrix. !>
[out]	NSPLIT	!> NSPLIT is INTEGER !> The number of blocks T splits into. 1 <= NSPLIT <= N. !>
[out]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into blocks. !> The first block consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 134 of file slarra.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N, NSPLIT
      REAL                SPLTOL, TNRM
*     ..
*     .. Array Arguments ..
      INTEGER            ISPLIT( * )
      REAL               D( * ), E( * ), E2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               EABS, TMP1
 
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Compute splitting points
      nsplit = 1
      IF(spltol.LT.zero) THEN
*        Criterion based on absolute off-diagonal value
         tmp1 = abs(spltol)* tnrm
         DO 9 i = 1, n-1
            eabs = abs( e(i) )
            IF( eabs .LE. tmp1) THEN
               e(i) = zero
               e2(i) = zero
               isplit( nsplit ) = i
               nsplit = nsplit + 1
            END IF
 9       CONTINUE
      ELSE
*        Criterion that guarantees relative accuracy
         DO 10 i = 1, n-1
            eabs = abs( e(i) )
            IF( eabs .LE. spltol * sqrt(abs(d(i)))*sqrt(abs(d(i+1))) )
     $      THEN
               e(i) = zero
               e2(i) = zero
               isplit( nsplit ) = i
               nsplit = nsplit + 1
            END IF
 10      CONTINUE
      ENDIF
      isplit( nsplit ) = n
 
      RETURN
*
*     End of SLARRA
*

slarrb()

subroutine slarrb	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	lld,
		integer	ifirst,
		integer	ilast,
		real	rtol1,
		real	rtol2,
		integer	offset,
		real, dimension( * )	w,
		real, dimension( * )	wgap,
		real, dimension( * )	werr,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		real	pivmin,
		real	spdiam,
		integer	twist,
		integer	info )

SLARRB provides limited bisection to locate eigenvalues for more accuracy.

Download SLARRB + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the relatively robust representation(RRR) L D L^T, SLARRB
!> does  bisection to refine the eigenvalues of L D L^T,
!> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
!> guesses for these eigenvalues are input in W, the corresponding estimate
!> of the error in these guesses and their gaps are input in WERR
!> and WGAP, respectively. During bisection, intervals
!> [left, right] are maintained by storing their mid-points and
!> semi-widths in the arrays W and WERR respectively.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is REAL array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	LLD	!> LLD is REAL array, dimension (N-1) !> The (N-1) elements L(i)*L(i)*D(i). !>
[in]	IFIRST	!> IFIRST is INTEGER !> The index of the first eigenvalue to be computed. !>
[in]	ILAST	!> ILAST is INTEGER !> The index of the last eigenvalue to be computed. !>
[in]	RTOL1	!> RTOL1 is REAL !>
[in]	RTOL2	!> RTOL2 is REAL !> Tolerance for the convergence of the bisection intervals. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) !> where GAP is the (estimated) distance to the nearest !> eigenvalue. !>
[in]	OFFSET	!> OFFSET is INTEGER !> Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET !> through ILAST-OFFSET elements of these arrays are to be used. !>
[in,out]	W	!> W is REAL array, dimension (N) !> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are !> estimates of the eigenvalues of L D L^T indexed IFIRST through !> ILAST. !> On output, these estimates are refined. !>
[in,out]	WGAP	!> WGAP is REAL array, dimension (N-1) !> On input, the (estimated) gaps between consecutive !> eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between !> eigenvalues I and I+1. Note that if IFIRST = ILAST !> then WGAP(IFIRST-OFFSET) must be set to ZERO. !> On output, these gaps are refined. !>
[in,out]	WERR	!> WERR is REAL array, dimension (N) !> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are !> the errors in the estimates of the corresponding elements in W. !> On output, these errors are refined. !>
[out]	WORK	!> WORK is REAL array, dimension (2*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (2*N) !> Workspace. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot in the Sturm sequence. !>
[in]	SPDIAM	!> SPDIAM is REAL !> The spectral diameter of the matrix. !>
[in]	TWIST	!> TWIST is INTEGER !> The twist index for the twisted factorization that is used !> for the negcount. !> TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T !> TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T !> TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) !>
[out]	INFO	!> INFO is INTEGER !> Error flag. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 193 of file slarrb.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N, OFFSET, TWIST
      REAL               PIVMIN, RTOL1, RTOL2, SPDIAM
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               D( * ), LLD( * ), W( * ),
     $                   WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, TWO, HALF
      parameter( zero = 0.0e0, two = 2.0e0,
     $                   half = 0.5e0 )
      INTEGER   MAXITR
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
     $                   OLNINT, PREV, R
      REAL               BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
     $                   RGAP, RIGHT, TMP, WIDTH
*     ..
*     .. External Functions ..
      INTEGER            SLANEG
      EXTERNAL           slaneg
*
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
      mnwdth = two * pivmin
*
      r = twist
      IF((r.LT.1).OR.(r.GT.n)) r = n
*
*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
*     for an unconverged interval is set to the index of the next unconverged
*     interval, and is -1 or 0 for a converged interval. Thus a linked
*     list of unconverged intervals is set up.
*
      i1 = ifirst
*     The number of unconverged intervals
      nint = 0
*     The last unconverged interval found
      prev = 0
 
      rgap = wgap( i1-offset )
      DO 75 i = i1, ilast
         k = 2*i
         ii = i - offset
         left = w( ii ) - werr( ii )
         right = w( ii ) + werr( ii )
         lgap = rgap
         rgap = wgap( ii )
         gap = min( lgap, rgap )
 
*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
*        Do while( NEGCNT(LEFT).GT.I-1 )
*
         back = werr( ii )
 20      CONTINUE
         negcnt = slaneg( n, d, lld, left, pivmin, r )
         IF( negcnt.GT.i-1 ) THEN
            left = left - back
            back = two*back
            GO TO 20
         END IF
*
*        Do while( NEGCNT(RIGHT).LT.I )
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
         back = werr( ii )
 50      CONTINUE
 
         negcnt = slaneg( n, d, lld, right, pivmin, r )
          IF( negcnt.LT.i ) THEN
             right = right + back
             back = two*back
             GO TO 50
          END IF
         width = half*abs( left - right )
         tmp = max( abs( left ), abs( right ) )
         cvrgd = max(rtol1*gap,rtol2*tmp)
         IF( width.LE.cvrgd .OR. width.LE.mnwdth ) THEN
*           This interval has already converged and does not need refinement.
*           (Note that the gaps might change through refining the
*            eigenvalues, however, they can only get bigger.)
*           Remove it from the list.
            iwork( k-1 ) = -1
*           Make sure that I1 always points to the first unconverged interval
            IF((i.EQ.i1).AND.(i.LT.ilast)) i1 = i + 1
            IF((prev.GE.i1).AND.(i.LE.ilast)) iwork( 2*prev-1 ) = i + 1
         ELSE
*           unconverged interval found
            prev = i
            nint = nint + 1
            iwork( k-1 ) = i + 1
            iwork( k ) = negcnt
         END IF
         work( k-1 ) = left
         work( k ) = right
 75   CONTINUE
 
*
*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
*     and while (ITER.LT.MAXITR)
*
      iter = 0
 80   CONTINUE
      prev = i1 - 1
      i = i1
      olnint = nint
 
      DO 100 ip = 1, olnint
         k = 2*i
         ii = i - offset
         rgap = wgap( ii )
         lgap = rgap
         IF(ii.GT.1) lgap = wgap( ii-1 )
         gap = min( lgap, rgap )
         next = iwork( k-1 )
         left = work( k-1 )
         right = work( k )
         mid = half*( left + right )
 
*        semiwidth of interval
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
         cvrgd = max(rtol1*gap,rtol2*tmp)
         IF( ( width.LE.cvrgd ) .OR. ( width.LE.mnwdth ).OR.
     $       ( iter.EQ.maxitr ) )THEN
*           reduce number of unconverged intervals
            nint = nint - 1
*           Mark interval as converged.
            iwork( k-1 ) = 0
            IF( i1.EQ.i ) THEN
               i1 = next
            ELSE
*              Prev holds the last unconverged interval previously examined
               IF(prev.GE.i1) iwork( 2*prev-1 ) = next
            END IF
            i = next
            GO TO 100
         END IF
         prev = i
*
*        Perform one bisection step
*
         negcnt = slaneg( n, d, lld, mid, pivmin, r )
         IF( negcnt.LE.i-1 ) THEN
            work( k-1 ) = mid
         ELSE
            work( k ) = mid
         END IF
         i = next
 100  CONTINUE
      iter = iter + 1
*     do another loop if there are still unconverged intervals
*     However, in the last iteration, all intervals are accepted
*     since this is the best we can do.
      IF( ( nint.GT.0 ).AND.(iter.LE.maxitr) ) GO TO 80
*
*
*     At this point, all the intervals have converged
      DO 110 i = ifirst, ilast
         k = 2*i
         ii = i - offset
*        All intervals marked by '0' have been refined.
         IF( iwork( k-1 ).EQ.0 ) THEN
            w( ii ) = half*( work( k-1 )+work( k ) )
            werr( ii ) = work( k ) - w( ii )
         END IF
 110  CONTINUE
*
      DO 111 i = ifirst+1, ilast
         k = 2*i
         ii = i - offset
         wgap( ii-1 ) = max( zero,
     $                     w(ii) - werr(ii) - w( ii-1 ) - werr( ii-1 ))
 111  CONTINUE
 
      RETURN
*
*     End of SLARRB
*

slarrc()

subroutine slarrc	(	character	jobt,
		integer	n,
		real	vl,
		real	vu,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real	pivmin,
		integer	eigcnt,
		integer	lcnt,
		integer	rcnt,
		integer	info )

SLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix.

Download SLARRC + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Find the number of eigenvalues of the symmetric tridiagonal matrix T
!> that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
!> if JOBT = 'L'.
!> 

Parameters

[in]	JOBT	!> JOBT is CHARACTER*1 !> = 'T': Compute Sturm count for matrix T. !> = 'L': Compute Sturm count for matrix L D L^T. !>
[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	VL	!> VL is REAL !> The lower bound for the eigenvalues. !>
[in]	VU	!> VU is REAL !> The upper bound for the eigenvalues. !>
[in]	D	!> D is REAL array, dimension (N) !> JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. !> JOBT = 'L': The N diagonal elements of the diagonal matrix D. !>
[in]	E	!> E is REAL array, dimension (N) !> JOBT = 'T': The N-1 offdiagonal elements of the matrix T. !> JOBT = 'L': The N-1 offdiagonal elements of the matrix L. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot in the Sturm sequence for T. !>
[out]	EIGCNT	!> EIGCNT is INTEGER !> The number of eigenvalues of the symmetric tridiagonal matrix T !> that are in the interval (VL,VU] !>
[out]	LCNT	!> LCNT is INTEGER !>
[out]	RCNT	!> RCNT is INTEGER !> The left and right negcounts of the interval. !>
[out]	INFO	!> INFO is INTEGER !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 135 of file slarrc.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOBT
      INTEGER            EIGCNT, INFO, LCNT, N, RCNT
      REAL               PIVMIN, VL, VU
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      LOGICAL            MATT
      REAL               LPIVOT, RPIVOT, SL, SU, TMP, TMP2
 
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      lcnt = 0
      rcnt = 0
      eigcnt = 0
      matt = lsame( jobt, 'T' )
 
 
      IF (matt) THEN
*        Sturm sequence count on T
         lpivot = d( 1 ) - vl
         rpivot = d( 1 ) - vu
         IF( lpivot.LE.zero ) THEN
            lcnt = lcnt + 1
         ENDIF
         IF( rpivot.LE.zero ) THEN
            rcnt = rcnt + 1
         ENDIF
         DO 10 i = 1, n-1
            tmp = e(i)**2
            lpivot = ( d( i+1 )-vl ) - tmp/lpivot
            rpivot = ( d( i+1 )-vu ) - tmp/rpivot
            IF( lpivot.LE.zero ) THEN
               lcnt = lcnt + 1
            ENDIF
            IF( rpivot.LE.zero ) THEN
               rcnt = rcnt + 1
            ENDIF
 10      CONTINUE
      ELSE
*        Sturm sequence count on L D L^T
         sl = -vl
         su = -vu
         DO 20 i = 1, n - 1
            lpivot = d( i ) + sl
            rpivot = d( i ) + su
            IF( lpivot.LE.zero ) THEN
               lcnt = lcnt + 1
            ENDIF
            IF( rpivot.LE.zero ) THEN
               rcnt = rcnt + 1
            ENDIF
            tmp = e(i) * d(i) * e(i)
*
            tmp2 = tmp / lpivot
            IF( tmp2.EQ.zero ) THEN
               sl =  tmp - vl
            ELSE
               sl = sl*tmp2 - vl
            END IF
*
            tmp2 = tmp / rpivot
            IF( tmp2.EQ.zero ) THEN
               su =  tmp - vu
            ELSE
               su = su*tmp2 - vu
            END IF
 20      CONTINUE
         lpivot = d( n ) + sl
         rpivot = d( n ) + su
         IF( lpivot.LE.zero ) THEN
            lcnt = lcnt + 1
         ENDIF
         IF( rpivot.LE.zero ) THEN
            rcnt = rcnt + 1
         ENDIF
      ENDIF
      eigcnt = rcnt - lcnt
 
      RETURN
*
*     End of SLARRC
*

slarrd()

subroutine slarrd	(	character	range,
		character	order,
		integer	n,
		real	vl,
		real	vu,
		integer	il,
		integer	iu,
		real, dimension( * )	gers,
		real	reltol,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( * )	e2,
		real	pivmin,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	m,
		real, dimension( * )	w,
		real, dimension( * )	werr,
		real	wl,
		real	wu,
		integer, dimension( * )	iblock,
		integer, dimension( * )	indexw,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

SLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy.

Download SLARRD + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLARRD computes the eigenvalues of a symmetric tridiagonal
!> matrix T to suitable accuracy. This is an auxiliary code to be
!> called from SSTEMR.
!> The user may ask for all eigenvalues, all eigenvalues
!> in the half-open interval (VL, VU], or the IL-th through IU-th
!> eigenvalues.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966.
!> 

Parameters

[in]	RANGE	!> RANGE is CHARACTER*1 !> = 'A': () all eigenvalues will be found. !> = 'V': () all eigenvalues in the half-open interval !> (VL, VU] will be found. !> = 'I': () the IL-th through IU-th eigenvalues (of the !> entire matrix) will be found. !>
[in]	ORDER	!> ORDER is CHARACTER*1 !> = 'B': () the eigenvalues will be grouped by !> split-off block (see IBLOCK, ISPLIT) and !> ordered from smallest to largest within !> the block. !> = 'E': () !> the eigenvalues for the entire matrix !> will be ordered from smallest to !> largest. !>
[in]	N	!> N is INTEGER !> The order of the tridiagonal matrix T. N >= 0. !>
[in]	VL	!> VL is REAL !> If RANGE='V', the lower bound of the interval to !> be searched for eigenvalues. Eigenvalues less than or equal !> to VL, or greater than VU, will not be returned. VL < VU. !> Not referenced if RANGE = 'A' or 'I'. !>
[in]	VU	!> VU is REAL !> If RANGE='V', the upper bound of the interval to !> be searched for eigenvalues. Eigenvalues less than or equal !> to VL, or greater than VU, will not be returned. VL < VU. !> Not referenced if RANGE = 'A' or 'I'. !>
[in]	IL	!> IL is INTEGER !> If RANGE='I', the index of the !> smallest eigenvalue to be returned. !> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. !> Not referenced if RANGE = 'A' or 'V'. !>
[in]	IU	!> IU is INTEGER !> If RANGE='I', the index of the !> largest eigenvalue to be returned. !> 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. !> Not referenced if RANGE = 'A' or 'V'. !>
[in]	GERS	!> GERS is REAL array, dimension (2*N) !> The N Gerschgorin intervals (the i-th Gerschgorin interval !> is (GERS(2*i-1), GERS(2*i)). !>
[in]	RELTOL	!> RELTOL is REAL !> The minimum relative width of an interval. When an interval !> is narrower than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[in]	D	!> D is REAL array, dimension (N) !> The n diagonal elements of the tridiagonal matrix T. !>
[in]	E	!> E is REAL array, dimension (N-1) !> The (n-1) off-diagonal elements of the tridiagonal matrix T. !>
[in]	E2	!> E2 is REAL array, dimension (N-1) !> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot allowed in the Sturm sequence for T. !>
[in]	NSPLIT	!> NSPLIT is INTEGER !> The number of diagonal blocks in the matrix T. !> 1 <= NSPLIT <= N. !>
[in]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into submatrices. !> The first submatrix consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !> (Only the first NSPLIT elements will actually be used, but !> since the user cannot know a priori what value NSPLIT will !> have, N words must be reserved for ISPLIT.) !>
[out]	M	!> M is INTEGER !> The actual number of eigenvalues found. 0 <= M <= N. !> (See also the description of INFO=2,3.) !>
[out]	W	!> W is REAL array, dimension (N) !> On exit, the first M elements of W will contain the !> eigenvalue approximations. SLARRD computes an interval !> I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue !> approximation is given as the interval midpoint !> W(j)= ( a_j + b_j)/2. The corresponding error is bounded by !> WERR(j) = abs( a_j - b_j)/2 !>
[out]	WERR	!> WERR is REAL array, dimension (N) !> The error bound on the corresponding eigenvalue approximation !> in W. !>
[out]	WL	!> WL is REAL !>
[out]	WU	!> WU is REAL !> The interval (WL, WU] contains all the wanted eigenvalues. !> If RANGE='V', then WL=VL and WU=VU. !> If RANGE='A', then WL and WU are the global Gerschgorin bounds !> on the spectrum. !> If RANGE='I', then WL and WU are computed by SLAEBZ from the !> index range specified. !>
[out]	IBLOCK	!> IBLOCK is INTEGER array, dimension (N) !> At each row/column j where E(j) is zero or small, the !> matrix T is considered to split into a block diagonal !> matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which !> block (from 1 to the number of blocks) the eigenvalue W(i) !> belongs. (SLARRD may use the remaining N-M elements as !> workspace.) !>
[out]	INDEXW	!> INDEXW is INTEGER array, dimension (N) !> The indices of the eigenvalues within each block (submatrix); !> for example, INDEXW(i)= j and IBLOCK(i)=k imply that the !> i-th eigenvalue W(i) is the j-th eigenvalue in block k. !>
[out]	WORK	!> WORK is REAL array, dimension (4*N) !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (3*N) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> > 0: some or all of the eigenvalues failed to converge or !> were not computed: !> =1 or 3: Bisection failed to converge for some !> eigenvalues; these eigenvalues are flagged by a !> negative block number. The effect is that the !> eigenvalues may not be as accurate as the !> absolute and relative tolerances. This is !> generally caused by unexpectedly inaccurate !> arithmetic. !> =2 or 3: RANGE='I' only: Not all of the eigenvalues !> IL:IU were found. !> Effect: M < IU+1-IL !> Cause: non-monotonic arithmetic, causing the !> Sturm sequence to be non-monotonic. !> Cure: recalculate, using RANGE='A', and pick !> out eigenvalues IL:IU. In some cases, !> increasing the PARAMETER may !> make things work. !> = 4: RANGE='I', and the Gershgorin interval !> initially used was too small. No eigenvalues !> were computed. !> Probable cause: your machine has sloppy !> floating-point arithmetic. !> Cure: Increase the PARAMETER , !> recompile, and try again. !>

Internal Parameters:

!>  FUDGE   REAL, default = 2
!>          A  to widen the Gershgorin intervals.  Ideally,
!>          a value of 1 should work, but on machines with sloppy
!>          arithmetic, this needs to be larger.  The default for
!>          publicly released versions should be large enough to handle
!>          the worst machine around.  Note that this has no effect
!>          on accuracy of the solution.
!> 

Contributors:

W. Kahan, University of California, Berkeley, USA
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 325 of file slarrd.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          ORDER, RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      REAL                PIVMIN, RELTOL, VL, VU, WL, WU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), INDEXW( * ),
     $                   ISPLIT( * ), IWORK( * )
      REAL               D( * ), E( * ), E2( * ),
     $                   GERS( * ), W( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, HALF, FUDGE
      parameter( zero = 0.0e0, one = 1.0e0,
     $                     two = 2.0e0, half = one/two,
     $                     fudge = two )
      INTEGER   ALLRNG, VALRNG, INDRNG
      parameter( allrng = 1, valrng = 2, indrng = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NCNVRG, TOOFEW
      INTEGER            I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
     $                   IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
     $                   ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
     $                   NWL, NWU
      REAL               ATOLI, EPS, GL, GU, RTOLI, TMP1, TMP2,
     $                   TNORM, UFLOW, WKILL, WLU, WUL
 
*     ..
*     .. Local Arrays ..
      INTEGER            IDUMMA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH
      EXTERNAL           lsame, ilaenv, slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           slaebz
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max, min
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Decode RANGE
*
      IF( lsame( range, 'A' ) ) THEN
         irange = allrng
      ELSE IF( lsame( range, 'V' ) ) THEN
         irange = valrng
      ELSE IF( lsame( range, 'I' ) ) THEN
         irange = indrng
      ELSE
         irange = 0
      END IF
*
*     Check for Errors
*
      IF( irange.LE.0 ) THEN
         info = -1
      ELSE IF( .NOT.(lsame(order,'B').OR.lsame(order,'E')) ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( irange.EQ.valrng ) THEN
         IF( vl.GE.vu )
     $      info = -5
      ELSE IF( irange.EQ.indrng .AND.
     $        ( il.LT.1 .OR. il.GT.max( 1, n ) ) ) THEN
         info = -6
      ELSE IF( irange.EQ.indrng .AND.
     $        ( iu.LT.min( n, il ) .OR. iu.GT.n ) ) THEN
         info = -7
      END IF
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
 
*     Initialize error flags
      info = 0
      ncnvrg = .false.
      toofew = .false.
 
*     Quick return if possible
      m = 0
      IF( n.EQ.0 ) RETURN
 
*     Simplification:
      IF( irange.EQ.indrng .AND. il.EQ.1 .AND. iu.EQ.n ) irange = 1
 
*     Get machine constants
      eps = slamch( 'P' )
      uflow = slamch( 'U' )
 
 
*     Special Case when N=1
*     Treat case of 1x1 matrix for quick return
      IF( n.EQ.1 ) THEN
         IF( (irange.EQ.allrng).OR.
     $       ((irange.EQ.valrng).AND.(d(1).GT.vl).AND.(d(1).LE.vu)).OR.
     $       ((irange.EQ.indrng).AND.(il.EQ.1).AND.(iu.EQ.1)) ) THEN
            m = 1
            w(1) = d(1)
*           The computation error of the eigenvalue is zero
            werr(1) = zero
            iblock( 1 ) = 1
            indexw( 1 ) = 1
         ENDIF
         RETURN
      END IF
 
*     NB is the minimum vector length for vector bisection, or 0
*     if only scalar is to be done.
      nb = ilaenv( 1, 'SSTEBZ', ' ', n, -1, -1, -1 )
      IF( nb.LE.1 ) nb = 0
 
*     Find global spectral radius
      gl = d(1)
      gu = d(1)
      DO 5 i = 1,n
         gl =  min( gl, gers( 2*i - 1))
         gu = max( gu, gers(2*i) )
 5    CONTINUE
*     Compute global Gerschgorin bounds and spectral diameter
      tnorm = max( abs( gl ), abs( gu ) )
      gl = gl - fudge*tnorm*eps*n - fudge*two*pivmin
      gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin
*     [JAN/28/2009] remove the line below since SPDIAM variable not use
*     SPDIAM = GU - GL
*     Input arguments for SLAEBZ:
*     The relative tolerance.  An interval (a,b] lies within
*     "relative tolerance" if  b-a < RELTOL*max(|a|,|b|),
      rtoli = reltol
*     Set the absolute tolerance for interval convergence to zero to force
*     interval convergence based on relative size of the interval.
*     This is dangerous because intervals might not converge when RELTOL is
*     small. But at least a very small number should be selected so that for
*     strongly graded matrices, the code can get relatively accurate
*     eigenvalues.
      atoli = fudge*two*uflow + fudge*two*pivmin
 
      IF( irange.EQ.indrng ) THEN
 
*        RANGE='I': Compute an interval containing eigenvalues
*        IL through IU. The initial interval [GL,GU] from the global
*        Gerschgorin bounds GL and GU is refined by SLAEBZ.
         itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
         work( n+1 ) = gl
         work( n+2 ) = gl
         work( n+3 ) = gu
         work( n+4 ) = gu
         work( n+5 ) = gl
         work( n+6 ) = gu
         iwork( 1 ) = -1
         iwork( 2 ) = -1
         iwork( 3 ) = n + 1
         iwork( 4 ) = n + 1
         iwork( 5 ) = il - 1
         iwork( 6 ) = iu
*
         CALL slaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin,
     $         d, e, e2, iwork( 5 ), work( n+1 ), work( n+5 ), iout,
     $                iwork, w, iblock, iinfo )
         IF( iinfo .NE. 0 ) THEN
            info = iinfo
            RETURN
         END IF
*        On exit, output intervals may not be ordered by ascending negcount
         IF( iwork( 6 ).EQ.iu ) THEN
            wl = work( n+1 )
            wlu = work( n+3 )
            nwl = iwork( 1 )
            wu = work( n+4 )
            wul = work( n+2 )
            nwu = iwork( 4 )
         ELSE
            wl = work( n+2 )
            wlu = work( n+4 )
            nwl = iwork( 2 )
            wu = work( n+3 )
            wul = work( n+1 )
            nwu = iwork( 3 )
         END IF
*        On exit, the interval [WL, WLU] contains a value with negcount NWL,
*        and [WUL, WU] contains a value with negcount NWU.
         IF( nwl.LT.0 .OR. nwl.GE.n .OR. nwu.LT.1 .OR. nwu.GT.n ) THEN
            info = 4
            RETURN
         END IF
 
      ELSEIF( irange.EQ.valrng ) THEN
         wl = vl
         wu = vu
 
      ELSEIF( irange.EQ.allrng ) THEN
         wl = gl
         wu = gu
      ENDIF
 
 
 
*     Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
*     NWL accumulates the number of eigenvalues .le. WL,
*     NWU accumulates the number of eigenvalues .le. WU
      m = 0
      iend = 0
      info = 0
      nwl = 0
      nwu = 0
*
      DO 70 jblk = 1, nsplit
         ioff = iend
         ibegin = ioff + 1
         iend = isplit( jblk )
         in = iend - ioff
*
         IF( in.EQ.1 ) THEN
*           1x1 block
            IF( wl.GE.d( ibegin )-pivmin )
     $         nwl = nwl + 1
            IF( wu.GE.d( ibegin )-pivmin )
     $         nwu = nwu + 1
            IF( irange.EQ.allrng .OR.
     $           ( wl.LT.d( ibegin )-pivmin
     $             .AND. wu.GE. d( ibegin )-pivmin ) ) THEN
               m = m + 1
               w( m ) = d( ibegin )
               werr(m) = zero
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               iblock( m ) = jblk
               indexw( m ) = 1
            END IF
 
*        Disabled 2x2 case because of a failure on the following matrix
*        RANGE = 'I', IL = IU = 4
*          Original Tridiagonal, d = [
*           -0.150102010615740E+00
*           -0.849897989384260E+00
*           -0.128208148052635E-15
*            0.128257718286320E-15
*          ];
*          e = [
*           -0.357171383266986E+00
*           -0.180411241501588E-15
*           -0.175152352710251E-15
*          ];
*
*         ELSE IF( IN.EQ.2 ) THEN
**           2x2 block
*            DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
*            TMP1 = HALF*(D(IBEGIN)+D(IEND))
*            L1 = TMP1 - DISC
*            IF( WL.GE. L1-PIVMIN )
*     $         NWL = NWL + 1
*            IF( WU.GE. L1-PIVMIN )
*     $         NWU = NWU + 1
*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
*     $          L1-PIVMIN ) ) THEN
*               M = M + 1
*               W( M ) = L1
**              The uncertainty of eigenvalues of a 2x2 matrix is very small
*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
*               IBLOCK( M ) = JBLK
*               INDEXW( M ) = 1
*            ENDIF
*            L2 = TMP1 + DISC
*            IF( WL.GE. L2-PIVMIN )
*     $         NWL = NWL + 1
*            IF( WU.GE. L2-PIVMIN )
*     $         NWU = NWU + 1
*            IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
*     $          L2-PIVMIN ) ) THEN
*               M = M + 1
*               W( M ) = L2
**              The uncertainty of eigenvalues of a 2x2 matrix is very small
*               WERR( M ) = EPS * ABS( W( M ) ) * TWO
*               IBLOCK( M ) = JBLK
*               INDEXW( M ) = 2
*            ENDIF
         ELSE
*           General Case - block of size IN >= 2
*           Compute local Gerschgorin interval and use it as the initial
*           interval for SLAEBZ
            gu = d( ibegin )
            gl = d( ibegin )
            tmp1 = zero
 
            DO 40 j = ibegin, iend
               gl =  min( gl, gers( 2*j - 1))
               gu = max( gu, gers(2*j) )
   40       CONTINUE
*           [JAN/28/2009]
*           change SPDIAM by TNORM in lines 2 and 3 thereafter
*           line 1: remove computation of SPDIAM (not useful anymore)
*           SPDIAM = GU - GL
*           GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
*           GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
            gl = gl - fudge*tnorm*eps*in - fudge*pivmin
            gu = gu + fudge*tnorm*eps*in + fudge*pivmin
*
            IF( irange.GT.1 ) THEN
               IF( gu.LT.wl ) THEN
*                 the local block contains none of the wanted eigenvalues
                  nwl = nwl + in
                  nwu = nwu + in
                  GO TO 70
               END IF
*              refine search interval if possible, only range (WL,WU] matters
               gl = max( gl, wl )
               gu = min( gu, wu )
               IF( gl.GE.gu )
     $            GO TO 70
            END IF
 
*           Find negcount of initial interval boundaries GL and GU
            work( n+1 ) = gl
            work( n+in+1 ) = gu
            CALL slaebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,
     $                   d( ibegin ), e( ibegin ), e2( ibegin ),
     $                   idumma, work( n+1 ), work( n+2*in+1 ), im,
     $                   iwork, w( m+1 ), iblock( m+1 ), iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = iinfo
               RETURN
            END IF
*
            nwl = nwl + iwork( 1 )
            nwu = nwu + iwork( in+1 )
            iwoff = m - iwork( 1 )
 
*           Compute Eigenvalues
            itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /
     $              log( two ) ) + 2
            CALL slaebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,
     $                   d( ibegin ), e( ibegin ), e2( ibegin ),
     $                   idumma, work( n+1 ), work( n+2*in+1 ), iout,
     $                   iwork, w( m+1 ), iblock( m+1 ), iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = iinfo
               RETURN
            END IF
*
*           Copy eigenvalues into W and IBLOCK
*           Use -JBLK for block number for unconverged eigenvalues.
*           Loop over the number of output intervals from SLAEBZ
            DO 60 j = 1, iout
*              eigenvalue approximation is middle point of interval
               tmp1 = half*( work( j+n )+work( j+in+n ) )
*              semi length of error interval
               tmp2 = half*abs( work( j+n )-work( j+in+n ) )
               IF( j.GT.iout-iinfo ) THEN
*                 Flag non-convergence.
                  ncnvrg = .true.
                  ib = -jblk
               ELSE
                  ib = jblk
               END IF
               DO 50 je = iwork( j ) + 1 + iwoff,
     $                 iwork( j+in ) + iwoff
                  w( je ) = tmp1
                  werr( je ) = tmp2
                  indexw( je ) = je - iwoff
                  iblock( je ) = ib
   50          CONTINUE
   60       CONTINUE
*
            m = m + im
         END IF
   70 CONTINUE
 
*     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
*     If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
      IF( irange.EQ.indrng ) THEN
         idiscl = il - 1 - nwl
         idiscu = nwu - iu
*
         IF( idiscl.GT.0 ) THEN
            im = 0
            DO 80 je = 1, m
*              Remove some of the smallest eigenvalues from the left so that
*              at the end IDISCL =0. Move all eigenvalues up to the left.
               IF( w( je ).LE.wlu .AND. idiscl.GT.0 ) THEN
                  idiscl = idiscl - 1
               ELSE
                  im = im + 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 80         CONTINUE
            m = im
         END IF
         IF( idiscu.GT.0 ) THEN
*           Remove some of the largest eigenvalues from the right so that
*           at the end IDISCU =0. Move all eigenvalues up to the left.
            im=m+1
            DO 81 je = m, 1, -1
               IF( w( je ).GE.wul .AND. idiscu.GT.0 ) THEN
                  idiscu = idiscu - 1
               ELSE
                  im = im - 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 81         CONTINUE
            jee = 0
            DO 82 je = im, m
               jee = jee + 1
               w( jee ) = w( je )
               werr( jee ) = werr( je )
               indexw( jee ) = indexw( je )
               iblock( jee ) = iblock( je )
 82         CONTINUE
            m = m-im+1
         END IF
 
         IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
*           Code to deal with effects of bad arithmetic. (If N(w) is
*           monotone non-decreasing, this should never happen.)
*           Some low eigenvalues to be discarded are not in (WL,WLU],
*           or high eigenvalues to be discarded are not in (WUL,WU]
*           so just kill off the smallest IDISCL/largest IDISCU
*           eigenvalues, by marking the corresponding IBLOCK = 0
            IF( idiscl.GT.0 ) THEN
               wkill = wu
               DO 100 jdisc = 1, idiscl
                  iw = 0
                  DO 90 je = 1, m
                     IF( iblock( je ).NE.0 .AND.
     $                    ( w( je ).LT.wkill .OR. iw.EQ.0 ) ) THEN
                        iw = je
                        wkill = w( je )
                     END IF
 90               CONTINUE
                  iblock( iw ) = 0
 100           CONTINUE
            END IF
            IF( idiscu.GT.0 ) THEN
               wkill = wl
               DO 120 jdisc = 1, idiscu
                  iw = 0
                  DO 110 je = 1, m
                     IF( iblock( je ).NE.0 .AND.
     $                    ( w( je ).GE.wkill .OR. iw.EQ.0 ) ) THEN
                        iw = je
                        wkill = w( je )
                     END IF
 110              CONTINUE
                  iblock( iw ) = 0
 120           CONTINUE
            END IF
*           Now erase all eigenvalues with IBLOCK set to zero
            im = 0
            DO 130 je = 1, m
               IF( iblock( je ).NE.0 ) THEN
                  im = im + 1
                  w( im ) = w( je )
                  werr( im ) = werr( je )
                  indexw( im ) = indexw( je )
                  iblock( im ) = iblock( je )
               END IF
 130        CONTINUE
            m = im
         END IF
         IF( idiscl.LT.0 .OR. idiscu.LT.0 ) THEN
            toofew = .true.
         END IF
      END IF
*
      IF(( irange.EQ.allrng .AND. m.NE.n ).OR.
     $   ( irange.EQ.indrng .AND. m.NE.iu-il+1 ) ) THEN
         toofew = .true.
      END IF
 
*     If ORDER='B', do nothing the eigenvalues are already sorted by
*        block.
*     If ORDER='E', sort the eigenvalues from smallest to largest
 
      IF( lsame(order,'E') .AND. nsplit.GT.1 ) THEN
         DO 150 je = 1, m - 1
            ie = 0
            tmp1 = w( je )
            DO 140 j = je + 1, m
               IF( w( j ).LT.tmp1 ) THEN
                  ie = j
                  tmp1 = w( j )
               END IF
  140       CONTINUE
            IF( ie.NE.0 ) THEN
               tmp2 = werr( ie )
               itmp1 = iblock( ie )
               itmp2 = indexw( ie )
               w( ie ) = w( je )
               werr( ie ) = werr( je )
               iblock( ie ) = iblock( je )
               indexw( ie ) = indexw( je )
               w( je ) = tmp1
               werr( je ) = tmp2
               iblock( je ) = itmp1
               indexw( je ) = itmp2
            END IF
  150    CONTINUE
      END IF
*
      info = 0
      IF( ncnvrg )
     $   info = info + 1
      IF( toofew )
     $   info = info + 2
      RETURN
*
*     End of SLARRD
*

slarre()

subroutine slarre	(	character	range,
		integer	n,
		real	vl,
		real	vu,
		integer	il,
		integer	iu,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( * )	e2,
		real	rtol1,
		real	rtol2,
		real	spltol,
		integer	nsplit,
		integer, dimension( * )	isplit,
		integer	m,
		real, dimension( * )	w,
		real, dimension( * )	werr,
		real, dimension( * )	wgap,
		integer, dimension( * )	iblock,
		integer, dimension( * )	indexw,
		real, dimension( * )	gers,
		real	pivmin,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each unreduced block Ti, finds base representations and eigenvalues.

Download SLARRE + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> To find the desired eigenvalues of a given real symmetric
!> tridiagonal matrix T, SLARRE sets any  off-diagonal
!> elements to zero, and for each unreduced block T_i, it finds
!> (a) a suitable shift at one end of the block's spectrum,
!> (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
!> (c) eigenvalues of each L_i D_i L_i^T.
!> The representations and eigenvalues found are then used by
!> SSTEMR to compute the eigenvectors of T.
!> The accuracy varies depending on whether bisection is used to
!> find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
!> conpute all and then discard any unwanted one.
!> As an added benefit, SLARRE also outputs the n
!> Gerschgorin intervals for the matrices L_i D_i L_i^T.
!> 

Parameters

[in]	RANGE	!> RANGE is CHARACTER*1 !> = 'A': () all eigenvalues will be found. !> = 'V': () all eigenvalues in the half-open interval !> (VL, VU] will be found. !> = 'I': () the IL-th through IU-th eigenvalues (of the !> entire matrix) will be found. !>
[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in,out]	VL	!> VL is REAL !> If RANGE='V', the lower bound for the eigenvalues. !> Eigenvalues less than or equal to VL, or greater than VU, !> will not be returned. VL < VU. !> If RANGE='I' or ='A', SLARRE computes bounds on the desired !> part of the spectrum. !>
[in,out]	VU	!> VU is REAL !> If RANGE='V', the upper bound for the eigenvalues. !> Eigenvalues less than or equal to VL, or greater than VU, !> will not be returned. VL < VU. !> If RANGE='I' or ='A', SLARRE computes bounds on the desired !> part of the spectrum. !>
[in]	IL	!> IL is INTEGER !> If RANGE='I', the index of the !> smallest eigenvalue to be returned. !> 1 <= IL <= IU <= N. !>
[in]	IU	!> IU is INTEGER !> If RANGE='I', the index of the !> largest eigenvalue to be returned. !> 1 <= IL <= IU <= N. !>
[in,out]	D	!> D is REAL array, dimension (N) !> On entry, the N diagonal elements of the tridiagonal !> matrix T. !> On exit, the N diagonal elements of the diagonal !> matrices D_i. !>
[in,out]	E	!> E is REAL array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) need not be set. !> On exit, E contains the subdiagonal elements of the unit !> bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, contain the base points sigma_i on output. !>
[in,out]	E2	!> E2 is REAL array, dimension (N) !> On entry, the first (N-1) entries contain the SQUARES of the !> subdiagonal elements of the tridiagonal matrix T; !> E2(N) need not be set. !> On exit, the entries E2( ISPLIT( I ) ), !> 1 <= I <= NSPLIT, have been set to zero !>
[in]	RTOL1	!> RTOL1 is REAL !>
[in]	RTOL2	!> RTOL2 is REAL !> Parameters for bisection. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) !>
[in]	SPLTOL	!> SPLTOL is REAL !> The threshold for splitting. !>
[out]	NSPLIT	!> NSPLIT is INTEGER !> The number of blocks T splits into. 1 <= NSPLIT <= N. !>
[out]	ISPLIT	!> ISPLIT is INTEGER array, dimension (N) !> The splitting points, at which T breaks up into blocks. !> The first block consists of rows/columns 1 to ISPLIT(1), !> the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), !> etc., and the NSPLIT-th consists of rows/columns !> ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. !>
[out]	M	!> M is INTEGER !> The total number of eigenvalues (of all L_i D_i L_i^T) !> found. !>
[out]	W	!> W is REAL array, dimension (N) !> The first M elements contain the eigenvalues. The !> eigenvalues of each of the blocks, L_i D_i L_i^T, are !> sorted in ascending order ( SLARRE may use the !> remaining N-M elements as workspace). !>
[out]	WERR	!> WERR is REAL array, dimension (N) !> The error bound on the corresponding eigenvalue in W. !>
[out]	WGAP	!> WGAP is REAL array, dimension (N) !> The separation from the right neighbor eigenvalue in W. !> The gap is only with respect to the eigenvalues of the same block !> as each block has its own representation tree. !> Exception: at the right end of a block we store the left gap !>
[out]	IBLOCK	!> IBLOCK is INTEGER array, dimension (N) !> The indices of the blocks (submatrices) associated with the !> corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue !> W(i) belongs to the first block from the top, =2 if W(i) !> belongs to the second block, etc. !>
[out]	INDEXW	!> INDEXW is INTEGER array, dimension (N) !> The indices of the eigenvalues within each block (submatrix); !> for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the !> i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 !>
[out]	GERS	!> GERS is REAL array, dimension (2*N) !> The N Gerschgorin intervals (the i-th Gerschgorin interval !> is (GERS(2*i-1), GERS(2*i)). !>
[out]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot in the Sturm sequence for T. !>
[out]	WORK	!> WORK is REAL array, dimension (6*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (5*N) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> > 0: A problem occurred in SLARRE. !> < 0: One of the called subroutines signaled an internal problem. !> Needs inspection of the corresponding parameter IINFO !> for further information. !> !> =-1: Problem in SLARRD. !> = 2: No base representation could be found in MAXTRY iterations. !> Increasing MAXTRY and recompilation might be a remedy. !> =-3: Problem in SLARRB when computing the refined root !> representation for SLASQ2. !> =-4: Problem in SLARRB when preforming bisection on the !> desired part of the spectrum. !> =-5: Problem in SLASQ2. !> =-6: Problem in SLASQ2. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  The base representations are required to suffer very little
!>  element growth and consequently define all their eigenvalues to
!>  high relative accuracy.
!> 

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 301 of file slarre.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          RANGE
      INTEGER            IL, INFO, IU, M, N, NSPLIT
      REAL               PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IBLOCK( * ), ISPLIT( * ), IWORK( * ),
     $                   INDEXW( * )
      REAL               D( * ), E( * ), E2( * ), GERS( * ),
     $                   W( * ),WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
     $                   MAXGROWTH, ONE, PERT, TWO, ZERO
      parameter( zero = 0.0e0, one = 1.0e0,
     $                     two = 2.0e0, four=4.0e0,
     $                     hndrd = 100.0e0,
     $                     pert = 4.0e0,
     $                     half = one/two, fourth = one/four, fac= half,
     $                     maxgrowth = 64.0e0, fudge = 2.0e0 )
      INTEGER            MAXTRY, ALLRNG, INDRNG, VALRNG
      parameter( maxtry = 6, allrng = 1, indrng = 2,
     $                     valrng = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FORCEB, NOREP, USEDQD
      INTEGER            CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
     $                   IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
     $                   WBEGIN, WEND
      REAL               AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
     $                   EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
     $                   RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
     $                   TAU, TMP, TMP1
 
 
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL                        SLAMCH
      EXTERNAL           slamch, lsame
 
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slarnv, slarra, slarrb, slarrc, slarrd,
     $                   slasq2, slarrk
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
 
*     ..
*     .. Executable Statements ..
*
 
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
*     Decode RANGE
*
      IF( lsame( range, 'A' ) ) THEN
         irange = allrng
      ELSE IF( lsame( range, 'V' ) ) THEN
         irange = valrng
      ELSE IF( lsame( range, 'I' ) ) THEN
         irange = indrng
      END IF
 
      m = 0
 
*     Get machine constants
      safmin = slamch( 'S' )
      eps = slamch( 'P' )
 
*     Set parameters
      rtl = hndrd*eps
*     If one were ever to ask for less initial precision in BSRTOL,
*     one should keep in mind that for the subset case, the extremal
*     eigenvalues must be at least as accurate as the current setting
*     (eigenvalues in the middle need not as much accuracy)
      bsrtol = sqrt(eps)*(0.5e-3)
 
*     Treat case of 1x1 matrix for quick return
      IF( n.EQ.1 ) THEN
         IF( (irange.EQ.allrng).OR.
     $       ((irange.EQ.valrng).AND.(d(1).GT.vl).AND.(d(1).LE.vu)).OR.
     $       ((irange.EQ.indrng).AND.(il.EQ.1).AND.(iu.EQ.1)) ) THEN
            m = 1
            w(1) = d(1)
*           The computation error of the eigenvalue is zero
            werr(1) = zero
            wgap(1) = zero
            iblock( 1 ) = 1
            indexw( 1 ) = 1
            gers(1) = d( 1 )
            gers(2) = d( 1 )
         ENDIF
*        store the shift for the initial RRR, which is zero in this case
         e(1) = zero
         RETURN
      END IF
 
*     General case: tridiagonal matrix of order > 1
*
*     Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
*     Compute maximum off-diagonal entry and pivmin.
      gl = d(1)
      gu = d(1)
      eold = zero
      emax = zero
      e(n) = zero
      DO 5 i = 1,n
         werr(i) = zero
         wgap(i) = zero
         eabs = abs( e(i) )
         IF( eabs .GE. emax ) THEN
            emax = eabs
         END IF
         tmp1 = eabs + eold
         gers( 2*i-1) = d(i) - tmp1
         gl =  min( gl, gers( 2*i - 1))
         gers( 2*i ) = d(i) + tmp1
         gu = max( gu, gers(2*i) )
         eold  = eabs
 5    CONTINUE
*     The minimum pivot allowed in the Sturm sequence for T
      pivmin = safmin * max( one, emax**2 )
*     Compute spectral diameter. The Gerschgorin bounds give an
*     estimate that is wrong by at most a factor of SQRT(2)
      spdiam = gu - gl
 
*     Compute splitting points
      CALL slarra( n, d, e, e2, spltol, spdiam,
     $                    nsplit, isplit, iinfo )
 
*     Can force use of bisection instead of faster DQDS.
*     Option left in the code for future multisection work.
      forceb = .false.
 
*     Initialize USEDQD, DQDS should be used for ALLRNG unless someone
*     explicitly wants bisection.
      usedqd = (( irange.EQ.allrng ) .AND. (.NOT.forceb))
 
      IF( (irange.EQ.allrng) .AND. (.NOT. forceb) ) THEN
*        Set interval [VL,VU] that contains all eigenvalues
         vl = gl
         vu = gu
      ELSE
*        We call SLARRD to find crude approximations to the eigenvalues
*        in the desired range. In case IRANGE = INDRNG, we also obtain the
*        interval (VL,VU] that contains all the wanted eigenvalues.
*        An interval [LEFT,RIGHT] has converged if
*        RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
*        SLARRD needs a WORK of size 4*N, IWORK of size 3*N
         CALL slarrd( range, 'B', n, vl, vu, il, iu, gers,
     $                    bsrtol, d, e, e2, pivmin, nsplit, isplit,
     $                    mm, w, werr, vl, vu, iblock, indexw,
     $                    work, iwork, iinfo )
         IF( iinfo.NE.0 ) THEN
            info = -1
            RETURN
         ENDIF
*        Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
         DO 14 i = mm+1,n
            w( i ) = zero
            werr( i ) = zero
            iblock( i ) = 0
            indexw( i ) = 0
 14      CONTINUE
      END IF
 
 
***
*     Loop over unreduced blocks
      ibegin = 1
      wbegin = 1
      DO 170 jblk = 1, nsplit
         iend = isplit( jblk )
         in = iend - ibegin + 1
 
*        1 X 1 block
         IF( in.EQ.1 ) THEN
            IF( (irange.EQ.allrng).OR.( (irange.EQ.valrng).AND.
     $         ( d( ibegin ).GT.vl ).AND.( d( ibegin ).LE.vu ) )
     $        .OR. ( (irange.EQ.indrng).AND.(iblock(wbegin).EQ.jblk))
     $        ) THEN
               m = m + 1
               w( m ) = d( ibegin )
               werr(m) = zero
*              The gap for a single block doesn't matter for the later
*              algorithm and is assigned an arbitrary large value
               wgap(m) = zero
               iblock( m ) = jblk
               indexw( m ) = 1
               wbegin = wbegin + 1
            ENDIF
*           E( IEND ) holds the shift for the initial RRR
            e( iend ) = zero
            ibegin = iend + 1
            GO TO 170
         END IF
*
*        Blocks of size larger than 1x1
*
*        E( IEND ) will hold the shift for the initial RRR, for now set it =0
         e( iend ) = zero
*
*        Find local outer bounds GL,GU for the block
         gl = d(ibegin)
         gu = d(ibegin)
         DO 15 i = ibegin , iend
            gl = min( gers( 2*i-1 ), gl )
            gu = max( gers( 2*i ), gu )
 15      CONTINUE
         spdiam = gu - gl
 
         IF(.NOT. ((irange.EQ.allrng).AND.(.NOT.forceb)) ) THEN
*           Count the number of eigenvalues in the current block.
            mb = 0
            DO 20 i = wbegin,mm
               IF( iblock(i).EQ.jblk ) THEN
                  mb = mb+1
               ELSE
                  GOTO 21
               ENDIF
 20         CONTINUE
 21         CONTINUE
 
            IF( mb.EQ.0) THEN
*              No eigenvalue in the current block lies in the desired range
*              E( IEND ) holds the shift for the initial RRR
               e( iend ) = zero
               ibegin = iend + 1
               GO TO 170
            ELSE
 
*              Decide whether dqds or bisection is more efficient
               usedqd = ( (mb .GT. fac*in) .AND. (.NOT.forceb) )
               wend = wbegin + mb - 1
*              Calculate gaps for the current block
*              In later stages, when representations for individual
*              eigenvalues are different, we use SIGMA = E( IEND ).
               sigma = zero
               DO 30 i = wbegin, wend - 1
                  wgap( i ) = max( zero,
     $                        w(i+1)-werr(i+1) - (w(i)+werr(i)) )
 30            CONTINUE
               wgap( wend ) = max( zero,
     $                     vu - sigma - (w( wend )+werr( wend )))
*              Find local index of the first and last desired evalue.
               indl = indexw(wbegin)
               indu = indexw( wend )
            ENDIF
         ENDIF
         IF(( (irange.EQ.allrng) .AND. (.NOT. forceb) ).OR.usedqd) THEN
*           Case of DQDS
*           Find approximations to the extremal eigenvalues of the block
            CALL slarrk( in, 1, gl, gu, d(ibegin),
     $               e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
            IF( iinfo.NE.0 ) THEN
               info = -1
               RETURN
            ENDIF
            isleft = max(gl, tmp - tmp1
     $               - hndrd * eps* abs(tmp - tmp1))
 
            CALL slarrk( in, in, gl, gu, d(ibegin),
     $               e2(ibegin), pivmin, rtl, tmp, tmp1, iinfo )
            IF( iinfo.NE.0 ) THEN
               info = -1
               RETURN
            ENDIF
            isrght = min(gu, tmp + tmp1
     $                 + hndrd * eps * abs(tmp + tmp1))
*           Improve the estimate of the spectral diameter
            spdiam = isrght - isleft
         ELSE
*           Case of bisection
*           Find approximations to the wanted extremal eigenvalues
            isleft = max(gl, w(wbegin) - werr(wbegin)
     $                  - hndrd * eps*abs(w(wbegin)- werr(wbegin) ))
            isrght = min(gu,w(wend) + werr(wend)
     $                  + hndrd * eps * abs(w(wend)+ werr(wend)))
         ENDIF
 
 
*        Decide whether the base representation for the current block
*        L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
*        should be on the left or the right end of the current block.
*        The strategy is to shift to the end which is "more populated"
*        Furthermore, decide whether to use DQDS for the computation of
*        the eigenvalue approximations at the end of SLARRE or bisection.
*        dqds is chosen if all eigenvalues are desired or the number of
*        eigenvalues to be computed is large compared to the blocksize.
         IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
*           If all the eigenvalues have to be computed, we use dqd
            usedqd = .true.
*           INDL is the local index of the first eigenvalue to compute
            indl = 1
            indu = in
*           MB =  number of eigenvalues to compute
            mb = in
            wend = wbegin + mb - 1
*           Define 1/4 and 3/4 points of the spectrum
            s1 = isleft + fourth * spdiam
            s2 = isrght - fourth * spdiam
         ELSE
*           SLARRD has computed IBLOCK and INDEXW for each eigenvalue
*           approximation.
*           choose sigma
            IF( usedqd ) THEN
               s1 = isleft + fourth * spdiam
               s2 = isrght - fourth * spdiam
            ELSE
               tmp = min(isrght,vu) -  max(isleft,vl)
               s1 =  max(isleft,vl) + fourth * tmp
               s2 =  min(isrght,vu) - fourth * tmp
            ENDIF
         ENDIF
 
*        Compute the negcount at the 1/4 and 3/4 points
         IF(mb.GT.1) THEN
            CALL slarrc( 'T', in, s1, s2, d(ibegin),
     $                    e(ibegin), pivmin, cnt, cnt1, cnt2, iinfo)
         ENDIF
 
         IF(mb.EQ.1) THEN
            sigma = gl
            sgndef = one
         ELSEIF( cnt1 - indl .GE. indu - cnt2 ) THEN
            IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
               sigma = max(isleft,gl)
            ELSEIF( usedqd ) THEN
*              use Gerschgorin bound as shift to get pos def matrix
*              for dqds
               sigma = isleft
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               sigma = max(isleft,vl)
            ENDIF
            sgndef = one
         ELSE
            IF( ( irange.EQ.allrng ) .AND. (.NOT.forceb) ) THEN
               sigma = min(isrght,gu)
            ELSEIF( usedqd ) THEN
*              use Gerschgorin bound as shift to get neg def matrix
*              for dqds
               sigma = isrght
            ELSE
*              use approximation of the first desired eigenvalue of the
*              block as shift
               sigma = min(isrght,vu)
            ENDIF
            sgndef = -one
         ENDIF
 
 
*        An initial SIGMA has been chosen that will be used for computing
*        T - SIGMA I = L D L^T
*        Define the increment TAU of the shift in case the initial shift
*        needs to be refined to obtain a factorization with not too much
*        element growth.
         IF( usedqd ) THEN
*           The initial SIGMA was to the outer end of the spectrum
*           the matrix is definite and we need not retreat.
            tau = spdiam*eps*n + two*pivmin
            tau = max( tau,two*eps*abs(sigma) )
         ELSE
            IF(mb.GT.1) THEN
               clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin)
               avgap = abs(clwdth / real(wend-wbegin))
               IF( sgndef.EQ.one ) THEN
                  tau = half*max(wgap(wbegin),avgap)
                  tau = max(tau,werr(wbegin))
               ELSE
                  tau = half*max(wgap(wend-1),avgap)
                  tau = max(tau,werr(wend))
               ENDIF
            ELSE
               tau = werr(wbegin)
            ENDIF
         ENDIF
*
         DO 80 idum = 1, maxtry
*           Compute L D L^T factorization of tridiagonal matrix T - sigma I.
*           Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
*           pivots in WORK(2*IN+1:3*IN)
            dpivot = d( ibegin ) - sigma
            work( 1 ) = dpivot
            dmax = abs( work(1) )
            j = ibegin
            DO 70 i = 1, in - 1
               work( 2*in+i ) = one / work( i )
               tmp = e( j )*work( 2*in+i )
               work( in+i ) = tmp
               dpivot = ( d( j+1 )-sigma ) - tmp*e( j )
               work( i+1 ) = dpivot
               dmax = max( dmax, abs(dpivot) )
               j = j + 1
 70         CONTINUE
*           check for element growth
            IF( dmax .GT. maxgrowth*spdiam ) THEN
               norep = .true.
            ELSE
               norep = .false.
            ENDIF
            IF( usedqd .AND. .NOT.norep ) THEN
*              Ensure the definiteness of the representation
*              All entries of D (of L D L^T) must have the same sign
               DO 71 i = 1, in
                  tmp = sgndef*work( i )
                  IF( tmp.LT.zero ) norep = .true.
 71            CONTINUE
            ENDIF
            IF(norep) THEN
*              Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
*              shift which makes the matrix definite. So we should end up
*              here really only in the case of IRANGE = VALRNG or INDRNG.
               IF( idum.EQ.maxtry-1 ) THEN
                  IF( sgndef.EQ.one ) THEN
*                    The fudged Gerschgorin shift should succeed
                     sigma =
     $                    gl - fudge*spdiam*eps*n - fudge*two*pivmin
                  ELSE
                     sigma =
     $                    gu + fudge*spdiam*eps*n + fudge*two*pivmin
                  END IF
               ELSE
                  sigma = sigma - sgndef * tau
                  tau = two * tau
               END IF
            ELSE
*              an initial RRR is found
               GO TO 83
            END IF
 80      CONTINUE
*        if the program reaches this point, no base representation could be
*        found in MAXTRY iterations.
         info = 2
         RETURN
 
 83      CONTINUE
*        At this point, we have found an initial base representation
*        T - SIGMA I = L D L^T with not too much element growth.
*        Store the shift.
         e( iend ) = sigma
*        Store D and L.
         CALL scopy( in, work, 1, d( ibegin ), 1 )
         CALL scopy( in-1, work( in+1 ), 1, e( ibegin ), 1 )
 
 
         IF(mb.GT.1 ) THEN
*
*           Perturb each entry of the base representation by a small
*           (but random) relative amount to overcome difficulties with
*           glued matrices.
*
            DO 122 i = 1, 4
               iseed( i ) = 1
 122        CONTINUE
 
            CALL slarnv(2, iseed, 2*in-1, work(1))
            DO 125 i = 1,in-1
               d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i))
               e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i))
 125        CONTINUE
            d(iend) = d(iend)*(one+eps*four*work(in))
*
         ENDIF
*
*        Don't update the Gerschgorin intervals because keeping track
*        of the updates would be too much work in SLARRV.
*        We update W instead and use it to locate the proper Gerschgorin
*        intervals.
 
*        Compute the required eigenvalues of L D L' by bisection or dqds
         IF ( .NOT.usedqd ) THEN
*           If SLARRD has been used, shift the eigenvalue approximations
*           according to their representation. This is necessary for
*           a uniform SLARRV since dqds computes eigenvalues of the
*           shifted representation. In SLARRV, W will always hold the
*           UNshifted eigenvalue approximation.
            DO 134 j=wbegin,wend
               w(j) = w(j) - sigma
               werr(j) = werr(j) + abs(w(j)) * eps
 134        CONTINUE
*           call SLARRB to reduce eigenvalue error of the approximations
*           from SLARRD
            DO 135 i = ibegin, iend-1
               work( i ) = d( i ) * e( i )**2
 135        CONTINUE
*           use bisection to find EV from INDL to INDU
            CALL slarrb(in, d(ibegin), work(ibegin),
     $                  indl, indu, rtol1, rtol2, indl-1,
     $                  w(wbegin), wgap(wbegin), werr(wbegin),
     $                  work( 2*n+1 ), iwork, pivmin, spdiam,
     $                  in, iinfo )
            IF( iinfo .NE. 0 ) THEN
               info = -4
               RETURN
            END IF
*           SLARRB computes all gaps correctly except for the last one
*           Record distance to VU/GU
            wgap( wend ) = max( zero,
     $           ( vu-sigma ) - ( w( wend ) + werr( wend ) ) )
            DO 138 i = indl, indu
               m = m + 1
               iblock(m) = jblk
               indexw(m) = i
 138        CONTINUE
         ELSE
*           Call dqds to get all eigs (and then possibly delete unwanted
*           eigenvalues).
*           Note that dqds finds the eigenvalues of the L D L^T representation
*           of T to high relative accuracy. High relative accuracy
*           might be lost when the shift of the RRR is subtracted to obtain
*           the eigenvalues of T. However, T is not guaranteed to define its
*           eigenvalues to high relative accuracy anyway.
*           Set RTOL to the order of the tolerance used in SLASQ2
*           This is an ESTIMATED error, the worst case bound is 4*N*EPS
*           which is usually too large and requires unnecessary work to be
*           done by bisection when computing the eigenvectors
            rtol = log(real(in)) * four * eps
            j = ibegin
            DO 140 i = 1, in - 1
               work( 2*i-1 ) = abs( d( j ) )
               work( 2*i ) = e( j )*e( j )*work( 2*i-1 )
               j = j + 1
  140       CONTINUE
            work( 2*in-1 ) = abs( d( iend ) )
            work( 2*in ) = zero
            CALL slasq2( in, work, iinfo )
            IF( iinfo .NE. 0 ) THEN
*              If IINFO = -5 then an index is part of a tight cluster
*              and should be changed. The index is in IWORK(1) and the
*              gap is in WORK(N+1)
               info = -5
               RETURN
            ELSE
*              Test that all eigenvalues are positive as expected
               DO 149 i = 1, in
                  IF( work( i ).LT.zero ) THEN
                     info = -6
                     RETURN
                  ENDIF
 149           CONTINUE
            END IF
            IF( sgndef.GT.zero ) THEN
               DO 150 i = indl, indu
                  m = m + 1
                  w( m ) = work( in-i+1 )
                  iblock( m ) = jblk
                  indexw( m ) = i
 150           CONTINUE
            ELSE
               DO 160 i = indl, indu
                  m = m + 1
                  w( m ) = -work( i )
                  iblock( m ) = jblk
                  indexw( m ) = i
 160           CONTINUE
            END IF
 
            DO 165 i = m - mb + 1, m
*              the value of RTOL below should be the tolerance in SLASQ2
               werr( i ) = rtol * abs( w(i) )
 165        CONTINUE
            DO 166 i = m - mb + 1, m - 1
*              compute the right gap between the intervals
               wgap( i ) = max( zero,
     $                          w(i+1)-werr(i+1) - (w(i)+werr(i)) )
 166        CONTINUE
            wgap( m ) = max( zero,
     $           ( vu-sigma ) - ( w( m ) + werr( m ) ) )
         END IF
*        proceed with next block
         ibegin = iend + 1
         wbegin = wend + 1
 170  CONTINUE
*
 
      RETURN
*
*     End of SLARRE
*

slarrf()

subroutine slarrf	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	l,
		real, dimension( * )	ld,
		integer	clstrt,
		integer	clend,
		real, dimension( * )	w,
		real, dimension( * )	wgap,
		real, dimension( * )	werr,
		real	spdiam,
		real	clgapl,
		real	clgapr,
		real	pivmin,
		real	sigma,
		real, dimension( * )	dplus,
		real, dimension( * )	lplus,
		real, dimension( * )	work,
		integer	info )

SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is relatively isolated.

Download SLARRF + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the initial representation L D L^T and its cluster of close
!> eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
!> W( CLEND ), SLARRF finds a new relatively robust representation
!> L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
!> eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix (subblock, if the matrix split). !>
[in]	D	!> D is REAL array, dimension (N) !> The N diagonal elements of the diagonal matrix D. !>
[in]	L	!> L is REAL array, dimension (N-1) !> The (N-1) subdiagonal elements of the unit bidiagonal !> matrix L. !>
[in]	LD	!> LD is REAL array, dimension (N-1) !> The (N-1) elements L(i)*D(i). !>
[in]	CLSTRT	!> CLSTRT is INTEGER !> The index of the first eigenvalue in the cluster. !>
[in]	CLEND	!> CLEND is INTEGER !> The index of the last eigenvalue in the cluster. !>
[in]	W	!> W is REAL array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> The eigenvalue APPROXIMATIONS of L D L^T in ascending order. !> W( CLSTRT ) through W( CLEND ) form the cluster of relatively !> close eigenalues. !>
[in,out]	WGAP	!> WGAP is REAL array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> The separation from the right neighbor eigenvalue in W. !>
[in]	WERR	!> WERR is REAL array, dimension !> dimension is >= (CLEND-CLSTRT+1) !> WERR contain the semiwidth of the uncertainty !> interval of the corresponding eigenvalue APPROXIMATION in W !>
[in]	SPDIAM	!> SPDIAM is REAL !> estimate of the spectral diameter obtained from the !> Gerschgorin intervals !>
[in]	CLGAPL	!> CLGAPL is REAL !>
[in]	CLGAPR	!> CLGAPR is REAL !> absolute gap on each end of the cluster. !> Set by the calling routine to protect against shifts too close !> to eigenvalues outside the cluster. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot allowed in the Sturm sequence. !>
[out]	SIGMA	!> SIGMA is REAL !> The shift used to form L(+) D(+) L(+)^T. !>
[out]	DPLUS	!> DPLUS is REAL array, dimension (N) !> The N diagonal elements of the diagonal matrix D(+). !>
[out]	LPLUS	!> LPLUS is REAL array, dimension (N-1) !> The first (N-1) elements of LPLUS contain the subdiagonal !> elements of the unit bidiagonal matrix L(+). !>
[out]	WORK	!> WORK is REAL array, dimension (2*N) !> Workspace. !>
[out]	INFO	!> INFO is INTEGER !> Signals processing OK (=0) or failure (=1) !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 189 of file slarrf.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            CLSTRT, CLEND, INFO, N
      REAL               CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
*     ..
*     .. Array Arguments ..
      REAL               D( * ), DPLUS( * ), L( * ), LD( * ),
     $          LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO
      parameter( one = 1.0e0, two = 2.0e0,
     $                     quart = 0.25e0,
     $                     maxgrowth1 = 8.e0,
     $                     maxgrowth2 = 8.e0 )
*     ..
*     .. Local Scalars ..
      LOGICAL   DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
      INTEGER            I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
      parameter( ktrymax = 1, sleft = 1, sright = 2 )
      REAL               AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
     $                   FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
     $                   MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
     $                   RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
*     ..
*     .. External Functions ..
      LOGICAL SISNAN
      REAL               SLAMCH
      EXTERNAL           sisnan, slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      fact = real(2**ktrymax)
      eps = slamch( 'Precision' )
      shift = 0
      forcer = .false.
 
 
*     Note that we cannot guarantee that for any of the shifts tried,
*     the factorization has a small or even moderate element growth.
*     There could be Ritz values at both ends of the cluster and despite
*     backing off, there are examples where all factorizations tried
*     (in IEEE mode, allowing zero pivots & infinities) have INFINITE
*     element growth.
*     For this reason, we should use PIVMIN in this subroutine so that at
*     least the L D L^T factorization exists. It can be checked afterwards
*     whether the element growth caused bad residuals/orthogonality.
 
*     Decide whether the code should accept the best among all
*     representations despite large element growth or signal INFO=1
*     Setting NOFAIL to .FALSE. for quick fix for bug 113
      nofail = .false.
*
 
*     Compute the average gap length of the cluster
      clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt)
      avgap = clwdth / real(clend-clstrt)
      mingap = min(clgapl, clgapr)
*     Initial values for shifts to both ends of cluster
      lsigma = min(w( clstrt ),w( clend )) - werr( clstrt )
      rsigma = max(w( clstrt ),w( clend )) + werr( clend )
 
*     Use a small fudge to make sure that we really shift to the outside
      lsigma = lsigma - abs(lsigma)* two * eps
      rsigma = rsigma + abs(rsigma)* two * eps
 
*     Compute upper bounds for how much to back off the initial shifts
      ldmax = quart * mingap + two * pivmin
      rdmax = quart * mingap + two * pivmin
 
      ldelta = max(avgap,wgap( clstrt ))/fact
      rdelta = max(avgap,wgap( clend-1 ))/fact
*
*     Initialize the record of the best representation found
*
      s = slamch( 'S' )
      smlgrowth = one / s
      fail = real(n-1)*mingap/(spdiam*eps)
      fail2 = real(n-1)*mingap/(spdiam*sqrt(eps))
      bestshift = lsigma
*
*     while (KTRY <= KTRYMAX)
      ktry = 0
      growthbound = maxgrowth1*spdiam
 
 5    CONTINUE
      sawnan1 = .false.
      sawnan2 = .false.
*     Ensure that we do not back off too much of the initial shifts
      ldelta = min(ldmax,ldelta)
      rdelta = min(rdmax,rdelta)
 
*     Compute the element growth when shifting to both ends of the cluster
*     accept the shift if there is no element growth at one of the two ends
 
*     Left end
      s = -lsigma
      dplus( 1 ) = d( 1 ) + s
      IF(abs(dplus(1)).LT.pivmin) THEN
         dplus(1) = -pivmin
*        Need to set SAWNAN1 because refined RRR test should not be used
*        in this case
         sawnan1 = .true.
      ENDIF
      max1 = abs( dplus( 1 ) )
      DO 6 i = 1, n - 1
         lplus( i ) = ld( i ) / dplus( i )
         s = s*lplus( i )*l( i ) - lsigma
         dplus( i+1 ) = d( i+1 ) + s
         IF(abs(dplus(i+1)).LT.pivmin) THEN
            dplus(i+1) = -pivmin
*           Need to set SAWNAN1 because refined RRR test should not be used
*           in this case
            sawnan1 = .true.
         ENDIF
         max1 = max( max1,abs(dplus(i+1)) )
 6    CONTINUE
      sawnan1 = sawnan1 .OR.  sisnan( max1 )
 
      IF( forcer .OR.
     $   (max1.LE.growthbound .AND. .NOT.sawnan1 ) ) THEN
         sigma = lsigma
         shift = sleft
         GOTO 100
      ENDIF
 
*     Right end
      s = -rsigma
      work( 1 ) = d( 1 ) + s
      IF(abs(work(1)).LT.pivmin) THEN
         work(1) = -pivmin
*        Need to set SAWNAN2 because refined RRR test should not be used
*        in this case
         sawnan2 = .true.
      ENDIF
      max2 = abs( work( 1 ) )
      DO 7 i = 1, n - 1
         work( n+i ) = ld( i ) / work( i )
         s = s*work( n+i )*l( i ) - rsigma
         work( i+1 ) = d( i+1 ) + s
         IF(abs(work(i+1)).LT.pivmin) THEN
            work(i+1) = -pivmin
*           Need to set SAWNAN2 because refined RRR test should not be used
*           in this case
            sawnan2 = .true.
         ENDIF
         max2 = max( max2,abs(work(i+1)) )
 7    CONTINUE
      sawnan2 = sawnan2 .OR.  sisnan( max2 )
 
      IF( forcer .OR.
     $   (max2.LE.growthbound .AND. .NOT.sawnan2 ) ) THEN
         sigma = rsigma
         shift = sright
         GOTO 100
      ENDIF
*     If we are at this point, both shifts led to too much element growth
 
*     Record the better of the two shifts (provided it didn't lead to NaN)
      IF(sawnan1.AND.sawnan2) THEN
*        both MAX1 and MAX2 are NaN
         GOTO 50
      ELSE
         IF( .NOT.sawnan1 ) THEN
            indx = 1
            IF(max1.LE.smlgrowth) THEN
               smlgrowth = max1
               bestshift = lsigma
            ENDIF
         ENDIF
         IF( .NOT.sawnan2 ) THEN
            IF(sawnan1 .OR. max2.LE.max1) indx = 2
            IF(max2.LE.smlgrowth) THEN
               smlgrowth = max2
               bestshift = rsigma
            ENDIF
         ENDIF
      ENDIF
 
*     If we are here, both the left and the right shift led to
*     element growth. If the element growth is moderate, then
*     we may still accept the representation, if it passes a
*     refined test for RRR. This test supposes that no NaN occurred.
*     Moreover, we use the refined RRR test only for isolated clusters.
      IF((clwdth.LT.mingap/real(128)) .AND.
     $   (min(max1,max2).LT.fail2)
     $  .AND.(.NOT.sawnan1).AND.(.NOT.sawnan2)) THEN
         dorrr1 = .true.
      ELSE
         dorrr1 = .false.
      ENDIF
      tryrrr1 = .true.
      IF( tryrrr1 .AND. dorrr1 ) THEN
      IF(indx.EQ.1) THEN
         tmp = abs( dplus( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 15 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod =
     $         ((dplus(i+1)*work(n+i+1))/(dplus(i)*work(n+i)))*oldp
            ELSE
               prod = prod*abs(work(n+i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( dplus( i ) * prod ))
 15      CONTINUE
         rrr1 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr1.LE.maxgrowth2) THEN
            sigma = lsigma
            shift = sleft
            GOTO 100
         ENDIF
      ELSE IF(indx.EQ.2) THEN
         tmp = abs( work( n ) )
         znm2 = one
         prod = one
         oldp = one
         DO 16 i = n-1, 1, -1
            IF( prod .LE. eps ) THEN
               prod = ((work(i+1)*lplus(i+1))/(work(i)*lplus(i)))*oldp
            ELSE
               prod = prod*abs(lplus(i))
            END IF
            oldp = prod
            znm2 = znm2 + prod**2
            tmp = max( tmp, abs( work( i ) * prod ))
 16      CONTINUE
         rrr2 = tmp/( spdiam * sqrt( znm2 ) )
         IF (rrr2.LE.maxgrowth2) THEN
            sigma = rsigma
            shift = sright
            GOTO 100
         ENDIF
      END IF
      ENDIF
 
 50   CONTINUE
 
      IF (ktry.LT.ktrymax) THEN
*        If we are here, both shifts failed also the RRR test.
*        Back off to the outside
         lsigma = max( lsigma - ldelta,
     $     lsigma - ldmax)
         rsigma = min( rsigma + rdelta,
     $     rsigma + rdmax )
         ldelta = two * ldelta
         rdelta = two * rdelta
         ktry = ktry + 1
         GOTO 5
      ELSE
*        None of the representations investigated satisfied our
*        criteria. Take the best one we found.
         IF((smlgrowth.LT.fail).OR.nofail) THEN
            lsigma = bestshift
            rsigma = bestshift
            forcer = .true.
            GOTO 5
         ELSE
            info = 1
            RETURN
         ENDIF
      END IF
 
 100  CONTINUE
      IF (shift.EQ.sleft) THEN
      ELSEIF (shift.EQ.sright) THEN
*        store new L and D back into DPLUS, LPLUS
         CALL scopy( n, work, 1, dplus, 1 )
         CALL scopy( n-1, work(n+1), 1, lplus, 1 )
      ENDIF
 
      RETURN
*
*     End of SLARRF
*

slarrj()

subroutine slarrj	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	e2,
		integer	ifirst,
		integer	ilast,
		real	rtol,
		integer	offset,
		real, dimension( * )	w,
		real, dimension( * )	werr,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		real	pivmin,
		real	spdiam,
		integer	info )

SLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T.

Download SLARRJ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Given the initial eigenvalue approximations of T, SLARRJ
!> does  bisection to refine the eigenvalues of T,
!> W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
!> guesses for these eigenvalues are input in W, the corresponding estimate
!> of the error in these guesses in WERR. During bisection, intervals
!> [left, right] are maintained by storing their mid-points and
!> semi-widths in the arrays W and WERR respectively.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. !>
[in]	D	!> D is REAL array, dimension (N) !> The N diagonal elements of T. !>
[in]	E2	!> E2 is REAL array, dimension (N-1) !> The Squares of the (N-1) subdiagonal elements of T. !>
[in]	IFIRST	!> IFIRST is INTEGER !> The index of the first eigenvalue to be computed. !>
[in]	ILAST	!> ILAST is INTEGER !> The index of the last eigenvalue to be computed. !>
[in]	RTOL	!> RTOL is REAL !> Tolerance for the convergence of the bisection intervals. !> An interval [LEFT,RIGHT] has converged if !> RIGHT-LEFT < RTOL*MAX(|LEFT|,|RIGHT|). !>
[in]	OFFSET	!> OFFSET is INTEGER !> Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET !> through ILAST-OFFSET elements of these arrays are to be used. !>
[in,out]	W	!> W is REAL array, dimension (N) !> On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are !> estimates of the eigenvalues of L D L^T indexed IFIRST through !> ILAST. !> On output, these estimates are refined. !>
[in,out]	WERR	!> WERR is REAL array, dimension (N) !> On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are !> the errors in the estimates of the corresponding elements in W. !> On output, these errors are refined. !>
[out]	WORK	!> WORK is REAL array, dimension (2*N) !> Workspace. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (2*N) !> Workspace. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot in the Sturm sequence for T. !>
[in]	SPDIAM	!> SPDIAM is REAL !> The spectral diameter of T. !>
[out]	INFO	!> INFO is INTEGER !> Error flag. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 165 of file slarrj.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N, OFFSET
      REAL               PIVMIN, RTOL, SPDIAM
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               D( * ), E2( * ), W( * ),
     $                   WERR( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, HALF
      parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
     $                   half = 0.5e0 )
      INTEGER   MAXITR
*     ..
*     .. Local Scalars ..
      INTEGER            CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
     $                   OLNINT, P, PREV, SAVI1
      REAL               DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
*
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         RETURN
      END IF
*
      maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
*
*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
*     for an unconverged interval is set to the index of the next unconverged
*     interval, and is -1 or 0 for a converged interval. Thus a linked
*     list of unconverged intervals is set up.
*
 
      i1 = ifirst
      i2 = ilast
*     The number of unconverged intervals
      nint = 0
*     The last unconverged interval found
      prev = 0
      DO 75 i = i1, i2
         k = 2*i
         ii = i - offset
         left = w( ii ) - werr( ii )
         mid = w(ii)
         right = w( ii ) + werr( ii )
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
 
*        The following test prevents the test of converged intervals
         IF( width.LT.rtol*tmp ) THEN
*           This interval has already converged and does not need refinement.
*           (Note that the gaps might change through refining the
*            eigenvalues, however, they can only get bigger.)
*           Remove it from the list.
            iwork( k-1 ) = -1
*           Make sure that I1 always points to the first unconverged interval
            IF((i.EQ.i1).AND.(i.LT.i2)) i1 = i + 1
            IF((prev.GE.i1).AND.(i.LE.i2)) iwork( 2*prev-1 ) = i + 1
         ELSE
*           unconverged interval found
            prev = i
*           Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*
*           Do while( CNT(LEFT).GT.I-1 )
*
            fac = one
 20         CONTINUE
            cnt = 0
            s = left
            dplus = d( 1 ) - s
            IF( dplus.LT.zero ) cnt = cnt + 1
            DO 30 j = 2, n
               dplus = d( j ) - s - e2( j-1 )/dplus
               IF( dplus.LT.zero ) cnt = cnt + 1
 30         CONTINUE
            IF( cnt.GT.i-1 ) THEN
               left = left - werr( ii )*fac
               fac = two*fac
               GO TO 20
            END IF
*
*           Do while( CNT(RIGHT).LT.I )
*
            fac = one
 50         CONTINUE
            cnt = 0
            s = right
            dplus = d( 1 ) - s
            IF( dplus.LT.zero ) cnt = cnt + 1
            DO 60 j = 2, n
               dplus = d( j ) - s - e2( j-1 )/dplus
               IF( dplus.LT.zero ) cnt = cnt + 1
 60         CONTINUE
            IF( cnt.LT.i ) THEN
               right = right + werr( ii )*fac
               fac = two*fac
               GO TO 50
            END IF
            nint = nint + 1
            iwork( k-1 ) = i + 1
            iwork( k ) = cnt
         END IF
         work( k-1 ) = left
         work( k ) = right
 75   CONTINUE
 
 
      savi1 = i1
*
*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
*     and while (ITER.LT.MAXITR)
*
      iter = 0
 80   CONTINUE
      prev = i1 - 1
      i = i1
      olnint = nint
 
      DO 100 p = 1, olnint
         k = 2*i
         ii = i - offset
         next = iwork( k-1 )
         left = work( k-1 )
         right = work( k )
         mid = half*( left + right )
 
*        semiwidth of interval
         width = right - mid
         tmp = max( abs( left ), abs( right ) )
 
         IF( ( width.LT.rtol*tmp ) .OR.
     $      (iter.EQ.maxitr) )THEN
*           reduce number of unconverged intervals
            nint = nint - 1
*           Mark interval as converged.
            iwork( k-1 ) = 0
            IF( i1.EQ.i ) THEN
               i1 = next
            ELSE
*              Prev holds the last unconverged interval previously examined
               IF(prev.GE.i1) iwork( 2*prev-1 ) = next
            END IF
            i = next
            GO TO 100
         END IF
         prev = i
*
*        Perform one bisection step
*
         cnt = 0
         s = mid
         dplus = d( 1 ) - s
         IF( dplus.LT.zero ) cnt = cnt + 1
         DO 90 j = 2, n
            dplus = d( j ) - s - e2( j-1 )/dplus
            IF( dplus.LT.zero ) cnt = cnt + 1
 90      CONTINUE
         IF( cnt.LE.i-1 ) THEN
            work( k-1 ) = mid
         ELSE
            work( k ) = mid
         END IF
         i = next
 
 100  CONTINUE
      iter = iter + 1
*     do another loop if there are still unconverged intervals
*     However, in the last iteration, all intervals are accepted
*     since this is the best we can do.
      IF( ( nint.GT.0 ).AND.(iter.LE.maxitr) ) GO TO 80
*
*
*     At this point, all the intervals have converged
      DO 110 i = savi1, ilast
         k = 2*i
         ii = i - offset
*        All intervals marked by '0' have been refined.
         IF( iwork( k-1 ).EQ.0 ) THEN
            w( ii ) = half*( work( k-1 )+work( k ) )
            werr( ii ) = work( k ) - w( ii )
         END IF
 110  CONTINUE
*
 
      RETURN
*
*     End of SLARRJ
*

slarrk()

subroutine slarrk	(	integer	n,
		integer	iw,
		real	gl,
		real	gu,
		real, dimension( * )	d,
		real, dimension( * )	e2,
		real	pivmin,
		real	reltol,
		real	w,
		real	werr,
		integer	info )

SLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy.

Download SLARRK + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLARRK computes one eigenvalue of a symmetric tridiagonal
!> matrix T to suitable accuracy. This is an auxiliary code to be
!> called from SSTEMR.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , Report CS41, Computer Science Dept., Stanford
!> University, July 21, 1966.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the tridiagonal matrix T. N >= 0. !>
[in]	IW	!> IW is INTEGER !> The index of the eigenvalues to be returned. !>
[in]	GL	!> GL is REAL !>
[in]	GU	!> GU is REAL !> An upper and a lower bound on the eigenvalue. !>
[in]	D	!> D is REAL array, dimension (N) !> The n diagonal elements of the tridiagonal matrix T. !>
[in]	E2	!> E2 is REAL array, dimension (N-1) !> The (n-1) squared off-diagonal elements of the tridiagonal matrix T. !>
[in]	PIVMIN	!> PIVMIN is REAL !> The minimum pivot allowed in the Sturm sequence for T. !>
[in]	RELTOL	!> RELTOL is REAL !> The minimum relative width of an interval. When an interval !> is narrower than RELTOL times the larger (in !> magnitude) endpoint, then it is considered to be !> sufficiently small, i.e., converged. Note: this should !> always be at least radix*machine epsilon. !>
[out]	W	!> W is REAL !>
[out]	WERR	!> WERR is REAL !> The error bound on the corresponding eigenvalue approximation !> in W. !>
[out]	INFO	!> INFO is INTEGER !> = 0: Eigenvalue converged !> = -1: Eigenvalue did NOT converge !>

Internal Parameters:

!>  FUDGE   REAL            , default = 2
!>          A  to widen the Gershgorin intervals.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 143 of file slarrk.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER   INFO, IW, N
      REAL                PIVMIN, RELTOL, GL, GU, W, WERR
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               FUDGE, HALF, TWO, ZERO
      parameter( half = 0.5e0, two = 2.0e0,
     $                     fudge = two, zero = 0.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER   I, IT, ITMAX, NEGCNT
      REAL               ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
     $                   TMP2, TNORM
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL   slamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         info = 0
         RETURN
      END IF
*
*     Get machine constants
      eps = slamch( 'P' )
 
      tnorm = max( abs( gl ), abs( gu ) )
      rtoli = reltol
      atoli = fudge*two*pivmin
 
      itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
     $           log( two ) ) + 2
 
      info = -1
 
      left = gl - fudge*tnorm*eps*n - fudge*two*pivmin
      right = gu + fudge*tnorm*eps*n + fudge*two*pivmin
      it = 0
 
 10   CONTINUE
*
*     Check if interval converged or maximum number of iterations reached
*
      tmp1 = abs( right - left )
      tmp2 = max( abs(right), abs(left) )
      IF( tmp1.LT.max( atoli, pivmin, rtoli*tmp2 ) ) THEN
         info = 0
         GOTO 30
      ENDIF
      IF(it.GT.itmax)
     $   GOTO 30
 
*
*     Count number of negative pivots for mid-point
*
      it = it + 1
      mid = half * (left + right)
      negcnt = 0
      tmp1 = d( 1 ) - mid
      IF( abs( tmp1 ).LT.pivmin )
     $   tmp1 = -pivmin
      IF( tmp1.LE.zero )
     $   negcnt = negcnt + 1
*
      DO 20 i = 2, n
         tmp1 = d( i ) - e2( i-1 ) / tmp1 - mid
         IF( abs( tmp1 ).LT.pivmin )
     $      tmp1 = -pivmin
         IF( tmp1.LE.zero )
     $      negcnt = negcnt + 1
 20   CONTINUE
 
      IF(negcnt.GE.iw) THEN
         right = mid
      ELSE
         left = mid
      ENDIF
      GOTO 10
 
 30   CONTINUE
*
*     Converged or maximum number of iterations reached
*
      w = half * (left + right)
      werr = half * abs( right - left )
 
      RETURN
*
*     End of SLARRK
*

slarrr()

subroutine slarrr	(	integer	n,
		real, dimension( * )	d,
		real, dimension( * )	e,
		integer	info )

SLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive computations which guarantee high relative accuracy in the eigenvalues.

Download SLARRR + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Perform tests to decide whether the symmetric tridiagonal matrix T
!> warrants expensive computations which guarantee high relative accuracy
!> in the eigenvalues.
!> 

Parameters

[in]	N	!> N is INTEGER !> The order of the matrix. N > 0. !>
[in]	D	!> D is REAL array, dimension (N) !> The N diagonal elements of the tridiagonal matrix T. !>
[in,out]	E	!> E is REAL array, dimension (N) !> On entry, the first (N-1) entries contain the subdiagonal !> elements of the tridiagonal matrix T; E(N) is set to ZERO. !>
[out]	INFO	!> INFO is INTEGER !> INFO = 0(default) : the matrix warrants computations preserving !> relative accuracy. !> INFO = 1 : the matrix warrants computations guaranteeing !> only absolute accuracy. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 93 of file slarrr.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N, INFO
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
*     ..
*
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, RELCOND
      parameter( zero = 0.0e0,
     $                     relcond = 0.999e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      LOGICAL            YESREL
      REAL               EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
     $          OFFDIG, OFFDIG2
 
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( n.LE.0 ) THEN
         info = 0
         RETURN
      END IF
*
*     As a default, do NOT go for relative-accuracy preserving computations.
      info = 1
 
      safmin = slamch( 'Safe minimum' )
      eps = slamch( 'Precision' )
      smlnum = safmin / eps
      rmin = sqrt( smlnum )
 
*     Tests for relative accuracy
*
*     Test for scaled diagonal dominance
*     Scale the diagonal entries to one and check whether the sum of the
*     off-diagonals is less than one
*
*     The sdd relative error bounds have a 1/(1- 2*x) factor in them,
*     x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
*     accuracy is promised.  In the notation of the code fragment below,
*     1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
*     We don't think it is worth going into "sdd mode" unless the relative
*     condition number is reasonable, not 1/macheps.
*     The threshold should be compatible with other thresholds used in the
*     code. We set  OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
*     to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
*     instead of the current OFFDIG + OFFDIG2 < 1
*
      yesrel = .true.
      offdig = zero
      tmp = sqrt(abs(d(1)))
      IF (tmp.LT.rmin) yesrel = .false.
      IF(.NOT.yesrel) GOTO 11
      DO 10 i = 2, n
         tmp2 = sqrt(abs(d(i)))
         IF (tmp2.LT.rmin) yesrel = .false.
         IF(.NOT.yesrel) GOTO 11
         offdig2 = abs(e(i-1))/(tmp*tmp2)
         IF(offdig+offdig2.GE.relcond) yesrel = .false.
         IF(.NOT.yesrel) GOTO 11
         tmp = tmp2
         offdig = offdig2
 10   CONTINUE
 11   CONTINUE
 
      IF( yesrel ) THEN
         info = 0
         RETURN
      ELSE
      ENDIF
*
 
*
*     *** MORE TO BE IMPLEMENTED ***
*
 
*
*     Test if the lower bidiagonal matrix L from T = L D L^T
*     (zero shift facto) is well conditioned
*
 
*
*     Test if the upper bidiagonal matrix U from T = U D U^T
*     (zero shift facto) is well conditioned.
*     In this case, the matrix needs to be flipped and, at the end
*     of the eigenvector computation, the flip needs to be applied
*     to the computed eigenvectors (and the support)
*
 
*
      RETURN
*
*     End of SLARRR
*

slartg()

subroutine slartg	(	real(wp)	f,
		real(wp)	g,
		real(wp)	c,
		real(wp)	s,
		real(wp)	r )

SLARTG generates a plane rotation with real cosine and real sine.

Purpose:

!>
!> SLARTG generates a plane rotation so that
!>
!>    [  C  S  ]  .  [ F ]  =  [ R ]
!>    [ -S  C  ]     [ G ]     [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>    R = sign(F) * sqrt(F**2 + G**2)
!>    C = F / R
!>    S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as SLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine SROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!>       floating point operations (saves work in SBDSQR when
!>       there are zeros on the diagonal).
!>
!> If F exceeds G in magnitude, C will be positive.
!>
!> Below, wp=>sp stands for single precision from LA_CONSTANTS module.
!> 

Parameters

[in]	F	!> F is REAL(wp) !> The first component of vector to be rotated. !>
[in]	G	!> G is REAL(wp) !> The second component of vector to be rotated. !>
[out]	C	!> C is REAL(wp) !> The cosine of the rotation. !>
[out]	S	!> S is REAL(wp) !> The sine of the rotation. !>
[out]	R	!> R is REAL(wp) !> The nonzero component of the rotated vector. !>

Author

Edward Anderson, Lockheed Martin

Date

July 2016

Contributors:

Weslley Pereira, University of Colorado Denver, USA

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> 

Definition at line 112 of file slartg.f90.

   use la_constants, &
   only: wp=>sp, zero=>szero, half=>shalf, one=>sone, &
         rtmin=>srtmin, rtmax=>srtmax, safmin=>ssafmin, safmax=>ssafmax
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp) :: c, f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, fs, g1, gs, p, u, uu
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, sign, sqrt
!  ..
!  .. Executable Statements ..
!
   f1 = abs( f )
   g1 = abs( g )
   if( g == zero ) then
      c = one
      s = zero
      r = f
   else if( f == zero ) then
      c = zero
      s = sign( one, g )
      r = g1
   else if( f1 > rtmin .and. f1 < rtmax .and. &
            g1 > rtmin .and. g1 < rtmax ) then
      d = sqrt( f*f + g*g )
      p = one / d
      c = f1*p
      s = g*sign( p, f )
      r = sign( d, f )
   else
      u = min( safmax, max( safmin, f1, g1 ) )
      uu = one / u
      fs = f*uu
      gs = g*uu
      d = sqrt( fs*fs + gs*gs )
      p = one / d
      c = abs( fs )*p
      s = gs*sign( p, f )
      r = sign( d, f )*u
   end if
   return

slartgp()

subroutine slartgp	(	real	f,
		real	g,
		real	cs,
		real	sn,
		real	r )

SLARTGP generates a plane rotation so that the diagonal is nonnegative.

Download SLARTGP + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLARTGP generates a plane rotation so that
!>
!>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
!>    [ -SN  CS  ]     [ G ]     [ 0 ]
!>
!> This is a slower, more accurate version of the Level 1 BLAS routine SROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then CS=(+/-)1 and SN=0.
!>    If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.
!>
!> The sign is chosen so that R >= 0.
!> 

Parameters

[in]	F	!> F is REAL !> The first component of vector to be rotated. !>
[in]	G	!> G is REAL !> The second component of vector to be rotated. !>
[out]	CS	!> CS is REAL !> The cosine of the rotation. !>
[out]	SN	!> SN is REAL !> The sine of the rotation. !>
[out]	R	!> R is REAL !> The nonzero component of the rotated vector. !> !> This version has a few statements commented out for thread safety !> (machine parameters are computed on each entry). 10 feb 03, SJH. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 94 of file slartgp.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               CS, F, G, R, SN
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               ONE
      parameter( one = 1.0e0 )
      REAL               TWO
      parameter( two = 2.0e0 )
*     ..
*     .. Local Scalars ..
*     LOGICAL            FIRST
      INTEGER            COUNT, I
      REAL               EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, int, log, max, sign, sqrt
*     ..
*     .. Save statement ..
*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
*     ..
*     .. Data statements ..
*     DATA               FIRST / .TRUE. /
*     ..
*     .. Executable Statements ..
*
*     IF( FIRST ) THEN
         safmin = slamch( 'S' )
         eps = slamch( 'E' )
         safmn2 = slamch( 'B' )**int( log( safmin / eps ) /
     $            log( slamch( 'B' ) ) / two )
         safmx2 = one / safmn2
*        FIRST = .FALSE.
*     END IF
      IF( g.EQ.zero ) THEN
         cs = sign( one, f )
         sn = zero
         r = abs( f )
      ELSE IF( f.EQ.zero ) THEN
         cs = zero
         sn = sign( one, g )
         r = abs( g )
      ELSE
         f1 = f
         g1 = g
         scale = max( abs( f1 ), abs( g1 ) )
         IF( scale.GE.safmx2 ) THEN
            count = 0
   10       CONTINUE
            count = count + 1
            f1 = f1*safmn2
            g1 = g1*safmn2
            scale = max( abs( f1 ), abs( g1 ) )
            IF( scale.GE.safmx2 .AND. count .LT. 20)
     $         GO TO 10
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
            DO 20 i = 1, count
               r = r*safmx2
   20       CONTINUE
         ELSE IF( scale.LE.safmn2 ) THEN
            count = 0
   30       CONTINUE
            count = count + 1
            f1 = f1*safmx2
            g1 = g1*safmx2
            scale = max( abs( f1 ), abs( g1 ) )
            IF( scale.LE.safmn2 )
     $         GO TO 30
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
            DO 40 i = 1, count
               r = r*safmn2
   40       CONTINUE
         ELSE
            r = sqrt( f1**2+g1**2 )
            cs = f1 / r
            sn = g1 / r
         END IF
         IF( r.LT.zero ) THEN
            cs = -cs
            sn = -sn
            r = -r
         END IF
      END IF
      RETURN
*
*     End of SLARTGP
*

slaruv()

subroutine slaruv	(	integer, dimension( 4 )	iseed,
		integer	n,
		real, dimension( n )	x )

SLARUV returns a vector of n random real numbers from a uniform distribution.

Download SLARUV + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLARUV returns a vector of n random real numbers from a uniform (0,1)
!> distribution (n <= 128).
!>
!> This is an auxiliary routine called by SLARNV and CLARNV.
!> 

Parameters

[in,out]	ISEED	!> ISEED is INTEGER array, dimension (4) !> On entry, the seed of the random number generator; the array !> elements must be between 0 and 4095, and ISEED(4) must be !> odd. !> On exit, the seed is updated. !>
[in]	N	!> N is INTEGER !> The number of random numbers to be generated. N <= 128. !>
[out]	X	!> X is REAL array, dimension (N) !> The generated random numbers. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  This routine uses a multiplicative congruential method with modulus
!>  2**48 and multiplier 33952834046453 (see G.S.Fishman,
!>  'Multiplicative congruential random number generators with modulus
!>  2**b: an exhaustive analysis for b = 32 and a partial analysis for
!>  b = 48', Math. Comp. 189, pp 331-344, 1990).
!>
!>  48-bit integers are stored in 4 integer array elements with 12 bits
!>  per element. Hence the routine is portable across machines with
!>  integers of 32 bits or more.
!> 

Definition at line 94 of file slaruv.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               X( N )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      parameter( one = 1.0e0 )
      INTEGER            LV, IPW2
      REAL               R
      parameter( lv = 128, ipw2 = 4096, r = one / ipw2 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
*     ..
*     .. Local Arrays ..
      INTEGER            MM( LV, 4 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min, mod, real
*     ..
*     .. Data statements ..
      DATA               ( mm( 1, j ), j = 1, 4 ) / 494, 322, 2508,
     $                   2549 /
      DATA               ( mm( 2, j ), j = 1, 4 ) / 2637, 789, 3754,
     $                   1145 /
      DATA               ( mm( 3, j ), j = 1, 4 ) / 255, 1440, 1766,
     $                   2253 /
      DATA               ( mm( 4, j ), j = 1, 4 ) / 2008, 752, 3572,
     $                   305 /
      DATA               ( mm( 5, j ), j = 1, 4 ) / 1253, 2859, 2893,
     $                   3301 /
      DATA               ( mm( 6, j ), j = 1, 4 ) / 3344, 123, 307,
     $                   1065 /
      DATA               ( mm( 7, j ), j = 1, 4 ) / 4084, 1848, 1297,
     $                   3133 /
      DATA               ( mm( 8, j ), j = 1, 4 ) / 1739, 643, 3966,
     $                   2913 /
      DATA               ( mm( 9, j ), j = 1, 4 ) / 3143, 2405, 758,
     $                   3285 /
      DATA               ( mm( 10, j ), j = 1, 4 ) / 3468, 2638, 2598,
     $                   1241 /
      DATA               ( mm( 11, j ), j = 1, 4 ) / 688, 2344, 3406,
     $                   1197 /
      DATA               ( mm( 12, j ), j = 1, 4 ) / 1657, 46, 2922,
     $                   3729 /
      DATA               ( mm( 13, j ), j = 1, 4 ) / 1238, 3814, 1038,
     $                   2501 /
      DATA               ( mm( 14, j ), j = 1, 4 ) / 3166, 913, 2934,
     $                   1673 /
      DATA               ( mm( 15, j ), j = 1, 4 ) / 1292, 3649, 2091,
     $                   541 /
      DATA               ( mm( 16, j ), j = 1, 4 ) / 3422, 339, 2451,
     $                   2753 /
      DATA               ( mm( 17, j ), j = 1, 4 ) / 1270, 3808, 1580,
     $                   949 /
      DATA               ( mm( 18, j ), j = 1, 4 ) / 2016, 822, 1958,
     $                   2361 /
      DATA               ( mm( 19, j ), j = 1, 4 ) / 154, 2832, 2055,
     $                   1165 /
      DATA               ( mm( 20, j ), j = 1, 4 ) / 2862, 3078, 1507,
     $                   4081 /
      DATA               ( mm( 21, j ), j = 1, 4 ) / 697, 3633, 1078,
     $                   2725 /
      DATA               ( mm( 22, j ), j = 1, 4 ) / 1706, 2970, 3273,
     $                   3305 /
      DATA               ( mm( 23, j ), j = 1, 4 ) / 491, 637, 17,
     $                   3069 /
      DATA               ( mm( 24, j ), j = 1, 4 ) / 931, 2249, 854,
     $                   3617 /
      DATA               ( mm( 25, j ), j = 1, 4 ) / 1444, 2081, 2916,
     $                   3733 /
      DATA               ( mm( 26, j ), j = 1, 4 ) / 444, 4019, 3971,
     $                   409 /
      DATA               ( mm( 27, j ), j = 1, 4 ) / 3577, 1478, 2889,
     $                   2157 /
      DATA               ( mm( 28, j ), j = 1, 4 ) / 3944, 242, 3831,
     $                   1361 /
      DATA               ( mm( 29, j ), j = 1, 4 ) / 2184, 481, 2621,
     $                   3973 /
      DATA               ( mm( 30, j ), j = 1, 4 ) / 1661, 2075, 1541,
     $                   1865 /
      DATA               ( mm( 31, j ), j = 1, 4 ) / 3482, 4058, 893,
     $                   2525 /
      DATA               ( mm( 32, j ), j = 1, 4 ) / 657, 622, 736,
     $                   1409 /
      DATA               ( mm( 33, j ), j = 1, 4 ) / 3023, 3376, 3992,
     $                   3445 /
      DATA               ( mm( 34, j ), j = 1, 4 ) / 3618, 812, 787,
     $                   3577 /
      DATA               ( mm( 35, j ), j = 1, 4 ) / 1267, 234, 2125,
     $                   77 /
      DATA               ( mm( 36, j ), j = 1, 4 ) / 1828, 641, 2364,
     $                   3761 /
      DATA               ( mm( 37, j ), j = 1, 4 ) / 164, 4005, 2460,
     $                   2149 /
      DATA               ( mm( 38, j ), j = 1, 4 ) / 3798, 1122, 257,
     $                   1449 /
      DATA               ( mm( 39, j ), j = 1, 4 ) / 3087, 3135, 1574,
     $                   3005 /
      DATA               ( mm( 40, j ), j = 1, 4 ) / 2400, 2640, 3912,
     $                   225 /
      DATA               ( mm( 41, j ), j = 1, 4 ) / 2870, 2302, 1216,
     $                   85 /
      DATA               ( mm( 42, j ), j = 1, 4 ) / 3876, 40, 3248,
     $                   3673 /
      DATA               ( mm( 43, j ), j = 1, 4 ) / 1905, 1832, 3401,
     $                   3117 /
      DATA               ( mm( 44, j ), j = 1, 4 ) / 1593, 2247, 2124,
     $                   3089 /
      DATA               ( mm( 45, j ), j = 1, 4 ) / 1797, 2034, 2762,
     $                   1349 /
      DATA               ( mm( 46, j ), j = 1, 4 ) / 1234, 2637, 149,
     $                   2057 /
      DATA               ( mm( 47, j ), j = 1, 4 ) / 3460, 1287, 2245,
     $                   413 /
      DATA               ( mm( 48, j ), j = 1, 4 ) / 328, 1691, 166,
     $                   65 /
      DATA               ( mm( 49, j ), j = 1, 4 ) / 2861, 496, 466,
     $                   1845 /
      DATA               ( mm( 50, j ), j = 1, 4 ) / 1950, 1597, 4018,
     $                   697 /
      DATA               ( mm( 51, j ), j = 1, 4 ) / 617, 2394, 1399,
     $                   3085 /
      DATA               ( mm( 52, j ), j = 1, 4 ) / 2070, 2584, 190,
     $                   3441 /
      DATA               ( mm( 53, j ), j = 1, 4 ) / 3331, 1843, 2879,
     $                   1573 /
      DATA               ( mm( 54, j ), j = 1, 4 ) / 769, 336, 153,
     $                   3689 /
      DATA               ( mm( 55, j ), j = 1, 4 ) / 1558, 1472, 2320,
     $                   2941 /
      DATA               ( mm( 56, j ), j = 1, 4 ) / 2412, 2407, 18,
     $                   929 /
      DATA               ( mm( 57, j ), j = 1, 4 ) / 2800, 433, 712,
     $                   533 /
      DATA               ( mm( 58, j ), j = 1, 4 ) / 189, 2096, 2159,
     $                   2841 /
      DATA               ( mm( 59, j ), j = 1, 4 ) / 287, 1761, 2318,
     $                   4077 /
      DATA               ( mm( 60, j ), j = 1, 4 ) / 2045, 2810, 2091,
     $                   721 /
      DATA               ( mm( 61, j ), j = 1, 4 ) / 1227, 566, 3443,
     $                   2821 /
      DATA               ( mm( 62, j ), j = 1, 4 ) / 2838, 442, 1510,
     $                   2249 /
      DATA               ( mm( 63, j ), j = 1, 4 ) / 209, 41, 449,
     $                   2397 /
      DATA               ( mm( 64, j ), j = 1, 4 ) / 2770, 1238, 1956,
     $                   2817 /
      DATA               ( mm( 65, j ), j = 1, 4 ) / 3654, 1086, 2201,
     $                   245 /
      DATA               ( mm( 66, j ), j = 1, 4 ) / 3993, 603, 3137,
     $                   1913 /
      DATA               ( mm( 67, j ), j = 1, 4 ) / 192, 840, 3399,
     $                   1997 /
      DATA               ( mm( 68, j ), j = 1, 4 ) / 2253, 3168, 1321,
     $                   3121 /
      DATA               ( mm( 69, j ), j = 1, 4 ) / 3491, 1499, 2271,
     $                   997 /
      DATA               ( mm( 70, j ), j = 1, 4 ) / 2889, 1084, 3667,
     $                   1833 /
      DATA               ( mm( 71, j ), j = 1, 4 ) / 2857, 3438, 2703,
     $                   2877 /
      DATA               ( mm( 72, j ), j = 1, 4 ) / 2094, 2408, 629,
     $                   1633 /
      DATA               ( mm( 73, j ), j = 1, 4 ) / 1818, 1589, 2365,
     $                   981 /
      DATA               ( mm( 74, j ), j = 1, 4 ) / 688, 2391, 2431,
     $                   2009 /
      DATA               ( mm( 75, j ), j = 1, 4 ) / 1407, 288, 1113,
     $                   941 /
      DATA               ( mm( 76, j ), j = 1, 4 ) / 634, 26, 3922,
     $                   2449 /
      DATA               ( mm( 77, j ), j = 1, 4 ) / 3231, 512, 2554,
     $                   197 /
      DATA               ( mm( 78, j ), j = 1, 4 ) / 815, 1456, 184,
     $                   2441 /
      DATA               ( mm( 79, j ), j = 1, 4 ) / 3524, 171, 2099,
     $                   285 /
      DATA               ( mm( 80, j ), j = 1, 4 ) / 1914, 1677, 3228,
     $                   1473 /
      DATA               ( mm( 81, j ), j = 1, 4 ) / 516, 2657, 4012,
     $                   2741 /
      DATA               ( mm( 82, j ), j = 1, 4 ) / 164, 2270, 1921,
     $                   3129 /
      DATA               ( mm( 83, j ), j = 1, 4 ) / 303, 2587, 3452,
     $                   909 /
      DATA               ( mm( 84, j ), j = 1, 4 ) / 2144, 2961, 3901,
     $                   2801 /
      DATA               ( mm( 85, j ), j = 1, 4 ) / 3480, 1970, 572,
     $                   421 /
      DATA               ( mm( 86, j ), j = 1, 4 ) / 119, 1817, 3309,
     $                   4073 /
      DATA               ( mm( 87, j ), j = 1, 4 ) / 3357, 676, 3171,
     $                   2813 /
      DATA               ( mm( 88, j ), j = 1, 4 ) / 837, 1410, 817,
     $                   2337 /
      DATA               ( mm( 89, j ), j = 1, 4 ) / 2826, 3723, 3039,
     $                   1429 /
      DATA               ( mm( 90, j ), j = 1, 4 ) / 2332, 2803, 1696,
     $                   1177 /
      DATA               ( mm( 91, j ), j = 1, 4 ) / 2089, 3185, 1256,
     $                   1901 /
      DATA               ( mm( 92, j ), j = 1, 4 ) / 3780, 184, 3715,
     $                   81 /
      DATA               ( mm( 93, j ), j = 1, 4 ) / 1700, 663, 2077,
     $                   1669 /
      DATA               ( mm( 94, j ), j = 1, 4 ) / 3712, 499, 3019,
     $                   2633 /
      DATA               ( mm( 95, j ), j = 1, 4 ) / 150, 3784, 1497,
     $                   2269 /
      DATA               ( mm( 96, j ), j = 1, 4 ) / 2000, 1631, 1101,
     $                   129 /
      DATA               ( mm( 97, j ), j = 1, 4 ) / 3375, 1925, 717,
     $                   1141 /
      DATA               ( mm( 98, j ), j = 1, 4 ) / 1621, 3912, 51,
     $                   249 /
      DATA               ( mm( 99, j ), j = 1, 4 ) / 3090, 1398, 981,
     $                   3917 /
      DATA               ( mm( 100, j ), j = 1, 4 ) / 3765, 1349, 1978,
     $                   2481 /
      DATA               ( mm( 101, j ), j = 1, 4 ) / 1149, 1441, 1813,
     $                   3941 /
      DATA               ( mm( 102, j ), j = 1, 4 ) / 3146, 2224, 3881,
     $                   2217 /
      DATA               ( mm( 103, j ), j = 1, 4 ) / 33, 2411, 76,
     $                   2749 /
      DATA               ( mm( 104, j ), j = 1, 4 ) / 3082, 1907, 3846,
     $                   3041 /
      DATA               ( mm( 105, j ), j = 1, 4 ) / 2741, 3192, 3694,
     $                   1877 /
      DATA               ( mm( 106, j ), j = 1, 4 ) / 359, 2786, 1682,
     $                   345 /
      DATA               ( mm( 107, j ), j = 1, 4 ) / 3316, 382, 124,
     $                   2861 /
      DATA               ( mm( 108, j ), j = 1, 4 ) / 1749, 37, 1660,
     $                   1809 /
      DATA               ( mm( 109, j ), j = 1, 4 ) / 185, 759, 3997,
     $                   3141 /
      DATA               ( mm( 110, j ), j = 1, 4 ) / 2784, 2948, 479,
     $                   2825 /
      DATA               ( mm( 111, j ), j = 1, 4 ) / 2202, 1862, 1141,
     $                   157 /
      DATA               ( mm( 112, j ), j = 1, 4 ) / 2199, 3802, 886,
     $                   2881 /
      DATA               ( mm( 113, j ), j = 1, 4 ) / 1364, 2423, 3514,
     $                   3637 /
      DATA               ( mm( 114, j ), j = 1, 4 ) / 1244, 2051, 1301,
     $                   1465 /
      DATA               ( mm( 115, j ), j = 1, 4 ) / 2020, 2295, 3604,
     $                   2829 /
      DATA               ( mm( 116, j ), j = 1, 4 ) / 3160, 1332, 1888,
     $                   2161 /
      DATA               ( mm( 117, j ), j = 1, 4 ) / 2785, 1832, 1836,
     $                   3365 /
      DATA               ( mm( 118, j ), j = 1, 4 ) / 2772, 2405, 1990,
     $                   361 /
      DATA               ( mm( 119, j ), j = 1, 4 ) / 1217, 3638, 2058,
     $                   2685 /
      DATA               ( mm( 120, j ), j = 1, 4 ) / 1822, 3661, 692,
     $                   3745 /
      DATA               ( mm( 121, j ), j = 1, 4 ) / 1245, 327, 1194,
     $                   2325 /
      DATA               ( mm( 122, j ), j = 1, 4 ) / 2252, 3660, 20,
     $                   3609 /
      DATA               ( mm( 123, j ), j = 1, 4 ) / 3904, 716, 3285,
     $                   3821 /
      DATA               ( mm( 124, j ), j = 1, 4 ) / 2774, 1842, 2046,
     $                   3537 /
      DATA               ( mm( 125, j ), j = 1, 4 ) / 997, 3987, 2107,
     $                   517 /
      DATA               ( mm( 126, j ), j = 1, 4 ) / 2573, 1368, 3508,
     $                   3017 /
      DATA               ( mm( 127, j ), j = 1, 4 ) / 1148, 1848, 3525,
     $                   2141 /
      DATA               ( mm( 128, j ), j = 1, 4 ) / 545, 2366, 3801,
     $                   1537 /
*     ..
*     .. Executable Statements ..
*
      i1 = iseed( 1 )
      i2 = iseed( 2 )
      i3 = iseed( 3 )
      i4 = iseed( 4 )
*
      DO 10 i = 1, min( n, lv )
*
  20     CONTINUE
*
*        Multiply the seed by i-th power of the multiplier modulo 2**48
*
         it4 = i4*mm( i, 4 )
         it3 = it4 / ipw2
         it4 = it4 - ipw2*it3
         it3 = it3 + i3*mm( i, 4 ) + i4*mm( i, 3 )
         it2 = it3 / ipw2
         it3 = it3 - ipw2*it2
         it2 = it2 + i2*mm( i, 4 ) + i3*mm( i, 3 ) + i4*mm( i, 2 )
         it1 = it2 / ipw2
         it2 = it2 - ipw2*it1
         it1 = it1 + i1*mm( i, 4 ) + i2*mm( i, 3 ) + i3*mm( i, 2 ) +
     $         i4*mm( i, 1 )
         it1 = mod( it1, ipw2 )
*
*        Convert 48-bit integer to a real number in the interval (0,1)
*
         x( i ) = r*( real( it1 )+r*( real( it2 )+r*( real( it3 )+r*
     $            real( it4 ) ) ) )
*
         IF (x( i ).EQ.1.0) THEN
*           If a real number has n bits of precision, and the first
*           n bits of the 48-bit integer above happen to be all 1 (which
*           will occur about once every 2**n calls), then X( I ) will
*           be rounded to exactly 1.0. In IEEE single precision arithmetic,
*           this will happen relatively often since n = 24.
*           Since X( I ) is not supposed to return exactly 0.0 or 1.0,
*           the statistically correct thing to do in this situation is
*           simply to iterate again.
*           N.B. the case X( I ) = 0.0 should not be possible.
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            i4 = i4 + 2
            GOTO 20
         END IF
*
   10 CONTINUE
*
*     Return final value of seed
*
      iseed( 1 ) = it1
      iseed( 2 ) = it2
      iseed( 3 ) = it3
      iseed( 4 ) = it4
      RETURN
*
*     End of SLARUV
*

slas2()

subroutine slas2	(	real	f,
		real	g,
		real	h,
		real	ssmin,
		real	ssmax )

SLAS2 computes singular values of a 2-by-2 triangular matrix.

Download SLAS2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLAS2  computes the singular values of the 2-by-2 matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, SSMIN is the smaller singular value and SSMAX is the
!> larger singular value.
!> 

Parameters

[in]	F	!> F is REAL !> The (1,1) element of the 2-by-2 matrix. !>
[in]	G	!> G is REAL !> The (1,2) element of the 2-by-2 matrix. !>
[in]	H	!> H is REAL !> The (2,2) element of the 2-by-2 matrix. !>
[out]	SSMIN	!> SSMIN is REAL !> The smaller singular value. !>
[out]	SSMAX	!> SSMAX is REAL !> The larger singular value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  Barring over/underflow, all output quantities are correct to within
!>  a few units in the last place (ulps), even in the absence of a guard
!>  digit in addition/subtraction.
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows, or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> 

Definition at line 106 of file slas2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               F, G, H, SSMAX, SSMIN
*     ..
*
*  ====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               ONE
      parameter( one = 1.0e0 )
      REAL               TWO
      parameter( two = 2.0e0 )
*     ..
*     .. Local Scalars ..
      REAL               AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. Executable Statements ..
*
      fa = abs( f )
      ga = abs( g )
      ha = abs( h )
      fhmn = min( fa, ha )
      fhmx = max( fa, ha )
      IF( fhmn.EQ.zero ) THEN
         ssmin = zero
         IF( fhmx.EQ.zero ) THEN
            ssmax = ga
         ELSE
            ssmax = max( fhmx, ga )*sqrt( one+
     $              ( min( fhmx, ga ) / max( fhmx, ga ) )**2 )
         END IF
      ELSE
         IF( ga.LT.fhmx ) THEN
            as = one + fhmn / fhmx
            at = ( fhmx-fhmn ) / fhmx
            au = ( ga / fhmx )**2
            c = two / ( sqrt( as*as+au )+sqrt( at*at+au ) )
            ssmin = fhmn*c
            ssmax = fhmx / c
         ELSE
            au = fhmx / ga
            IF( au.EQ.zero ) THEN
*
*              Avoid possible harmful underflow if exponent range
*              asymmetric (true SSMIN may not underflow even if
*              AU underflows)
*
               ssmin = ( fhmn*fhmx ) / ga
               ssmax = ga
            ELSE
               as = one + fhmn / fhmx
               at = ( fhmx-fhmn ) / fhmx
               c = one / ( sqrt( one+( as*au )**2 )+
     $             sqrt( one+( at*au )**2 ) )
               ssmin = ( fhmn*c )*au
               ssmin = ssmin + ssmin
               ssmax = ga / ( c+c )
            END IF
         END IF
      END IF
      RETURN
*
*     End of SLAS2
*

slascl()

subroutine slascl	(	character	type,
		integer	kl,
		integer	ku,
		real	cfrom,
		real	cto,
		integer	m,
		integer	n,
		real, dimension( lda, * )	a,
		integer	lda,
		integer	info )

SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.

Download SLASCL + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASCL multiplies the M by N real matrix A by the real scalar
!> CTO/CFROM.  This is done without over/underflow as long as the final
!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!> A may be full, upper triangular, lower triangular, upper Hessenberg,
!> or banded.
!> 

Parameters

[in]	TYPE	!> TYPE is CHARACTER*1 !> TYPE indices the storage type of the input matrix. !> = 'G': A is a full matrix. !> = 'L': A is a lower triangular matrix. !> = 'U': A is an upper triangular matrix. !> = 'H': A is an upper Hessenberg matrix. !> = 'B': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the lower !> half stored. !> = 'Q': A is a symmetric band matrix with lower bandwidth KL !> and upper bandwidth KU and with the only the upper !> half stored. !> = 'Z': A is a band matrix with lower bandwidth KL and upper !> bandwidth KU. See SGBTRF for storage details. !>
[in]	KL	!> KL is INTEGER !> The lower bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !>
[in]	KU	!> KU is INTEGER !> The upper bandwidth of A. Referenced only if TYPE = 'B', !> 'Q' or 'Z'. !>
[in]	CFROM	!> CFROM is REAL !>
[in]	CTO	!> CTO is REAL !> !> The matrix A is multiplied by CTO/CFROM. A(I,J) is computed !> without over/underflow if the final result CTO*A(I,J)/CFROM !> can be represented without over/underflow. CFROM must be !> nonzero. !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in,out]	A	!> A is REAL array, dimension (LDA,N) !> The matrix to be multiplied by CTO/CFROM. See TYPE for the !> storage type. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. !> If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M); !> TYPE = 'B', LDA >= KL+1; !> TYPE = 'Q', LDA >= KU+1; !> TYPE = 'Z', LDA >= 2*KL+KU+1. !>
[out]	INFO	!> INFO is INTEGER !> 0 - successful exit !> <0 - if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 142 of file slascl.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TYPE
      INTEGER            INFO, KL, KU, LDA, M, N
      REAL               CFROM, CTO
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e0, one = 1.0e0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      INTEGER            I, ITYPE, J, K1, K2, K3, K4
      REAL               BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, SISNAN
      REAL               SLAMCH
      EXTERNAL           lsame, slamch, sisnan
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      info = 0
*
      IF( lsame( TYPE, 'G' ) ) THEN
         itype = 0
      ELSE IF( lsame( TYPE, 'L' ) ) THEN
         itype = 1
      ELSE IF( lsame( TYPE, 'U' ) ) THEN
         itype = 2
      ELSE IF( lsame( TYPE, 'H' ) ) THEN
         itype = 3
      ELSE IF( lsame( TYPE, 'B' ) ) THEN
         itype = 4
      ELSE IF( lsame( TYPE, 'Q' ) ) THEN
         itype = 5
      ELSE IF( lsame( TYPE, 'Z' ) ) THEN
         itype = 6
      ELSE
         itype = -1
      END IF
*
      IF( itype.EQ.-1 ) THEN
         info = -1
      ELSE IF( cfrom.EQ.zero .OR. sisnan(cfrom) ) THEN
         info = -4
      ELSE IF( sisnan(cto) ) THEN
         info = -5
      ELSE IF( m.LT.0 ) THEN
         info = -6
      ELSE IF( n.LT.0 .OR. ( itype.EQ.4 .AND. n.NE.m ) .OR.
     $         ( itype.EQ.5 .AND. n.NE.m ) ) THEN
         info = -7
      ELSE IF( itype.LE.3 .AND. lda.LT.max( 1, m ) ) THEN
         info = -9
      ELSE IF( itype.GE.4 ) THEN
         IF( kl.LT.0 .OR. kl.GT.max( m-1, 0 ) ) THEN
            info = -2
         ELSE IF( ku.LT.0 .OR. ku.GT.max( n-1, 0 ) .OR.
     $            ( ( itype.EQ.4 .OR. itype.EQ.5 ) .AND. kl.NE.ku ) )
     $             THEN
            info = -3
         ELSE IF( ( itype.EQ.4 .AND. lda.LT.kl+1 ) .OR.
     $            ( itype.EQ.5 .AND. lda.LT.ku+1 ) .OR.
     $            ( itype.EQ.6 .AND. lda.LT.2*kl+ku+1 ) ) THEN
            info = -9
         END IF
      END IF
*
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASCL', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( n.EQ.0 .OR. m.EQ.0 )
     $   RETURN
*
*     Get machine parameters
*
      smlnum = slamch( 'S' )
      bignum = one / smlnum
*
      cfromc = cfrom
      ctoc = cto
*
   10 CONTINUE
      cfrom1 = cfromc*smlnum
      IF( cfrom1.EQ.cfromc ) THEN
!        CFROMC is an inf.  Multiply by a correctly signed zero for
!        finite CTOC, or a NaN if CTOC is infinite.
         mul = ctoc / cfromc
         done = .true.
         cto1 = ctoc
      ELSE
         cto1 = ctoc / bignum
         IF( cto1.EQ.ctoc ) THEN
!           CTOC is either 0 or an inf.  In both cases, CTOC itself
!           serves as the correct multiplication factor.
            mul = ctoc
            done = .true.
            cfromc = one
         ELSE IF( abs( cfrom1 ).GT.abs( ctoc ) .AND. ctoc.NE.zero ) THEN
            mul = smlnum
            done = .false.
            cfromc = cfrom1
         ELSE IF( abs( cto1 ).GT.abs( cfromc ) ) THEN
            mul = bignum
            done = .false.
            ctoc = cto1
         ELSE
            mul = ctoc / cfromc
            done = .true.
         END IF
      END IF
*
      IF( itype.EQ.0 ) THEN
*
*        Full matrix
*
         DO 30 j = 1, n
            DO 20 i = 1, m
               a( i, j ) = a( i, j )*mul
   20       CONTINUE
   30    CONTINUE
*
      ELSE IF( itype.EQ.1 ) THEN
*
*        Lower triangular matrix
*
         DO 50 j = 1, n
            DO 40 i = j, m
               a( i, j ) = a( i, j )*mul
   40       CONTINUE
   50    CONTINUE
*
      ELSE IF( itype.EQ.2 ) THEN
*
*        Upper triangular matrix
*
         DO 70 j = 1, n
            DO 60 i = 1, min( j, m )
               a( i, j ) = a( i, j )*mul
   60       CONTINUE
   70    CONTINUE
*
      ELSE IF( itype.EQ.3 ) THEN
*
*        Upper Hessenberg matrix
*
         DO 90 j = 1, n
            DO 80 i = 1, min( j+1, m )
               a( i, j ) = a( i, j )*mul
   80       CONTINUE
   90    CONTINUE
*
      ELSE IF( itype.EQ.4 ) THEN
*
*        Lower half of a symmetric band matrix
*
         k3 = kl + 1
         k4 = n + 1
         DO 110 j = 1, n
            DO 100 i = 1, min( k3, k4-j )
               a( i, j ) = a( i, j )*mul
  100       CONTINUE
  110    CONTINUE
*
      ELSE IF( itype.EQ.5 ) THEN
*
*        Upper half of a symmetric band matrix
*
         k1 = ku + 2
         k3 = ku + 1
         DO 130 j = 1, n
            DO 120 i = max( k1-j, 1 ), k3
               a( i, j ) = a( i, j )*mul
  120       CONTINUE
  130    CONTINUE
*
      ELSE IF( itype.EQ.6 ) THEN
*
*        Band matrix
*
         k1 = kl + ku + 2
         k2 = kl + 1
         k3 = 2*kl + ku + 1
         k4 = kl + ku + 1 + m
         DO 150 j = 1, n
            DO 140 i = max( k1-j, k2 ), min( k3, k4-j )
               a( i, j ) = a( i, j )*mul
  140       CONTINUE
  150    CONTINUE
*
      END IF
*
      IF( .NOT.done )
     $   GO TO 10
*
      RETURN
*
*     End of SLASCL
*

slasd0()

subroutine slasd0	(	integer	n,
		integer	sqre,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldvt, * )	vt,
		integer	ldvt,
		integer	smlsiz,
		integer, dimension( * )	iwork,
		real, dimension( * )	work,
		integer	info )

SLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d and off-diagonal e. Used by sbdsdc.

Download SLASD0 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Using a divide and conquer approach, SLASD0 computes the singular
!> value decomposition (SVD) of a real upper bidiagonal N-by-M
!> matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
!> The algorithm computes orthogonal matrices U and VT such that
!> B = U * S * VT. The singular values S are overwritten on D.
!>
!> A related subroutine, SLASDA, computes only the singular values,
!> and optionally, the singular vectors in compact form.
!> 

Parameters

[in]	N	!> N is INTEGER !> On entry, the row dimension of the upper bidiagonal matrix. !> This is also the dimension of the main diagonal array D. !>
[in]	SQRE	!> SQRE is INTEGER !> Specifies the column dimension of the bidiagonal matrix. !> = 0: The bidiagonal matrix has column dimension M = N; !> = 1: The bidiagonal matrix has column dimension M = N+1; !>
[in,out]	D	!> D is REAL array, dimension (N) !> On entry D contains the main diagonal of the bidiagonal !> matrix. !> On exit D, if INFO = 0, contains its singular values. !>
[in,out]	E	!> E is REAL array, dimension (M-1) !> Contains the subdiagonal entries of the bidiagonal matrix. !> On exit, E has been destroyed. !>
[out]	U	!> U is REAL array, dimension (LDU, N) !> On exit, U contains the left singular vectors. !>
[in]	LDU	!> LDU is INTEGER !> On entry, leading dimension of U. !>
[out]	VT	!> VT is REAL array, dimension (LDVT, M) !> On exit, VT**T contains the right singular vectors. !>
[in]	LDVT	!> LDVT is INTEGER !> On entry, leading dimension of VT. !>
[in]	SMLSIZ	!> SMLSIZ is INTEGER !> On entry, maximum size of the subproblems at the !> bottom of the computation tree. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (8*N) !>
[out]	WORK	!> WORK is REAL array, dimension (3*M**2+2*M) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 148 of file slasd0.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, N, SMLSIZ, SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
      REAL               ALPHA, BETA
*     ..
*     .. External Subroutines ..
      EXTERNAL           slasd1, slasdq, slasdt, xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( n.LT.0 ) THEN
         info = -1
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -2
      END IF
*
      m = n + sqre
*
      IF( ldu.LT.n ) THEN
         info = -6
      ELSE IF( ldvt.LT.m ) THEN
         info = -8
      ELSE IF( smlsiz.LT.3 ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD0', -info )
         RETURN
      END IF
*
*     If the input matrix is too small, call SLASDQ to find the SVD.
*
      IF( n.LE.smlsiz ) THEN
         CALL slasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldvt, u, ldu, u,
     $                ldu, work, info )
         RETURN
      END IF
*
*     Set up the computation tree.
*
      inode = 1
      ndiml = inode + n
      ndimr = ndiml + n
      idxq = ndimr + n
      iwk = idxq + n
      CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
     $             iwork( ndimr ), smlsiz )
*
*     For the nodes on bottom level of the tree, solve
*     their subproblems by SLASDQ.
*
      ndb1 = ( nd+1 ) / 2
      ncc = 0
      DO 30 i = ndb1, nd
*
*     IC : center row of each node
*     NL : number of rows of left  subproblem
*     NR : number of rows of right subproblem
*     NLF: starting row of the left   subproblem
*     NRF: starting row of the right  subproblem
*
         i1 = i - 1
         ic = iwork( inode+i1 )
         nl = iwork( ndiml+i1 )
         nlp1 = nl + 1
         nr = iwork( ndimr+i1 )
         nrp1 = nr + 1
         nlf = ic - nl
         nrf = ic + 1
         sqrei = 1
         CALL slasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ), e( nlf ),
     $                vt( nlf, nlf ), ldvt, u( nlf, nlf ), ldu,
     $                u( nlf, nlf ), ldu, work, info )
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         itemp = idxq + nlf - 2
         DO 10 j = 1, nl
            iwork( itemp+j ) = j
   10    CONTINUE
         IF( i.EQ.nd ) THEN
            sqrei = sqre
         ELSE
            sqrei = 1
         END IF
         nrp1 = nr + sqrei
         CALL slasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ), e( nrf ),
     $                vt( nrf, nrf ), ldvt, u( nrf, nrf ), ldu,
     $                u( nrf, nrf ), ldu, work, info )
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         itemp = idxq + ic
         DO 20 j = 1, nr
            iwork( itemp+j-1 ) = j
   20    CONTINUE
   30 CONTINUE
*
*     Now conquer each subproblem bottom-up.
*
      DO 50 lvl = nlvl, 1, -1
*
*        Find the first node LF and last node LL on the
*        current level LVL.
*
         IF( lvl.EQ.1 ) THEN
            lf = 1
            ll = 1
         ELSE
            lf = 2**( lvl-1 )
            ll = 2*lf - 1
         END IF
         DO 40 i = lf, ll
            im1 = i - 1
            ic = iwork( inode+im1 )
            nl = iwork( ndiml+im1 )
            nr = iwork( ndimr+im1 )
            nlf = ic - nl
            IF( ( sqre.EQ.0 ) .AND. ( i.EQ.ll ) ) THEN
               sqrei = sqre
            ELSE
               sqrei = 1
            END IF
            idxqc = idxq + nlf - 1
            alpha = d( ic )
            beta = e( ic )
            CALL slasd1( nl, nr, sqrei, d( nlf ), alpha, beta,
     $                   u( nlf, nlf ), ldu, vt( nlf, nlf ), ldvt,
     $                   iwork( idxqc ), iwork( iwk ), work, info )
*
*     Report the possible convergence failure.
*
            IF( info.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of SLASD0
*

slasd1()

subroutine slasd1	(	integer	nl,
		integer	nr,
		integer	sqre,
		real, dimension( * )	d,
		real	alpha,
		real	beta,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldvt, * )	vt,
		integer	ldvt,
		integer, dimension( * )	idxq,
		integer, dimension( * )	iwork,
		real, dimension( * )	work,
		integer	info )

SLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc.

Download SLASD1 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
!> where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
!>
!> A related subroutine SLASD7 handles the case in which the singular
!> values (and the singular vectors in factored form) are desired.
!>
!> SLASD1 computes the SVD as follows:
!>
!>               ( D1(in)    0    0       0 )
!>   B = U(in) * (   Z1**T   a   Z2**T    b ) * VT(in)
!>               (   0       0   D2(in)   0 )
!>
!>     = U(out) * ( D(out) 0) * VT(out)
!>
!> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M
!> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!> elsewhere; and the entry b is empty if SQRE = 0.
!>
!> The left singular vectors of the original matrix are stored in U, and
!> the transpose of the right singular vectors are stored in VT, and the
!> singular values are in D.  The algorithm consists of three stages:
!>
!>    The first stage consists of deflating the size of the problem
!>    when there are multiple singular values or when there are zeros 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 SLASD2.
!>
!>    The second stage consists of calculating the updated
!>    singular values. This is done by finding the square roots of the
!>    roots of the secular equation via the routine SLASD4 (as called
!>    by SLASD3). This routine also calculates the singular vectors of
!>    the current problem.
!>
!>    The final stage consists of computing the updated singular vectors
!>    directly using the updated singular values.  The singular vectors
!>    for the current problem are multiplied with the singular vectors
!>    from the overall problem.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has row dimension N = NL + NR + 1, !> and column dimension M = N + SQRE. !>
[in,out]	D	!> D is REAL array, dimension (NL+NR+1). !> N = NL+NR+1 !> On entry D(1:NL,1:NL) contains the singular values of the !> upper block; and D(NL+2:N) contains the singular values of !> the lower block. On exit D(1:N) contains the singular values !> of the modified matrix. !>
[in,out]	ALPHA	!> ALPHA is REAL !> Contains the diagonal element associated with the added row. !>
[in,out]	BETA	!> BETA is REAL !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	U	!> U is REAL array, dimension (LDU,N) !> On entry U(1:NL, 1:NL) contains the left singular vectors of !> the upper block; U(NL+2:N, NL+2:N) contains the left singular !> vectors of the lower block. On exit U contains the left !> singular vectors of the bidiagonal matrix. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= max( 1, N ). !>
[in,out]	VT	!> VT is REAL array, dimension (LDVT,M) !> where M = N + SQRE. !> On entry VT(1:NL+1, 1:NL+1)**T contains the right singular !> vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains !> the right singular vectors of the lower block. On exit !> VT**T contains the right singular vectors of the !> bidiagonal matrix. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= max( 1, M ). !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension (N) !> This contains the permutation which will reintegrate the !> subproblem just solved back into sorted order, i.e. !> D( IDXQ( I = 1, N ) ) will be in ascending order. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (4*N) !>
[out]	WORK	!> WORK is REAL array, dimension (3*M**2+2*M) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 202 of file slasd1.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDU, LDVT, NL, NR, SQRE
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            IDXQ( * ), IWORK( * )
      REAL               D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
*
      REAL               ONE, ZERO
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
     $                   IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
      REAL               ORGNRM
*     ..
*     .. External Subroutines ..
      EXTERNAL           slamrg, slascl, slasd2, slasd3, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -3
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD1', -info )
         RETURN
      END IF
*
      n = nl + nr + 1
      m = n + sqre
*
*     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 SLASD2 and SLASD3.
*
      ldu2 = n
      ldvt2 = m
*
      iz = 1
      isigma = iz + m
      iu2 = isigma + n
      ivt2 = iu2 + ldu2*n
      iq = ivt2 + ldvt2*m
*
      idx = 1
      idxc = idx + n
      coltyp = idxc + n
      idxp = coltyp + n
*
*     Scale.
*
      orgnrm = max( abs( alpha ), abs( beta ) )
      d( nl+1 ) = zero
      DO 10 i = 1, n
         IF( abs( d( i ) ).GT.orgnrm ) THEN
            orgnrm = abs( d( i ) )
         END IF
   10 CONTINUE
      CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
      alpha = alpha / orgnrm
      beta = beta / orgnrm
*
*     Deflate singular values.
*
      CALL slasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,
     $             vt, ldvt, work( isigma ), work( iu2 ), ldu2,
     $             work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ),
     $             iwork( idxc ), idxq, iwork( coltyp ), info )
*
*     Solve Secular Equation and update singular vectors.
*
      ldq = k
      CALL slasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),
     $             u, ldu, work( iu2 ), ldu2, vt, ldvt, work( ivt2 ),
     $             ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ),
     $             info )
*
*     Report the possible convergence failure.
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
*
*     Unscale.
*
      CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
*
*     Prepare the IDXQ sorting permutation.
*
      n1 = k
      n2 = n - k
      CALL slamrg( n1, n2, d, 1, -1, idxq )
*
      RETURN
*
*     End of SLASD1
*

slasd2()

subroutine slasd2	(	integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		real, dimension( * )	d,
		real, dimension( * )	z,
		real	alpha,
		real	beta,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldvt, * )	vt,
		integer	ldvt,
		real, dimension( * )	dsigma,
		real, dimension( ldu2, * )	u2,
		integer	ldu2,
		real, dimension( ldvt2, * )	vt2,
		integer	ldvt2,
		integer, dimension( * )	idxp,
		integer, dimension( * )	idx,
		integer, dimension( * )	idxc,
		integer, dimension( * )	idxq,
		integer, dimension( * )	coltyp,
		integer	info )

SLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc.

Download SLASD2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD2 merges the two sets of singular values 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
!> singular values 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.
!>
!> SLASD2 is called from SLASD1.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, !> This is the order of the related secular equation. 1 <= K <=N. !>
[in,out]	D	!> D is REAL array, dimension (N) !> On entry D contains the singular values of the two submatrices !> to be combined. On exit D contains the trailing (N-K) updated !> singular values (those which were deflated) sorted into !> increasing order. !>
[out]	Z	!> Z is REAL array, dimension (N) !> On exit Z contains the updating row vector in the secular !> equation. !>
[in]	ALPHA	!> ALPHA is REAL !> Contains the diagonal element associated with the added row. !>
[in]	BETA	!> BETA is REAL !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	U	!> U is REAL array, dimension (LDU,N) !> On entry U contains the left singular vectors of two !> submatrices in the two square blocks with corners at (1,1), !> (NL, NL), and (NL+2, NL+2), (N,N). !> On exit U contains the trailing (N-K) updated left singular !> vectors (those which were deflated) in its last N-K columns. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= N. !>
[in,out]	VT	!> VT is REAL array, dimension (LDVT,M) !> On entry VT**T contains the right singular vectors of two !> submatrices in the two square blocks with corners at (1,1), !> (NL+1, NL+1), and (NL+2, NL+2), (M,M). !> On exit VT**T contains the trailing (N-K) updated right singular !> vectors (those which were deflated) in its last N-K columns. !> In case SQRE =1, the last row of VT spans the right null !> space. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= M. !>
[out]	DSIGMA	!> DSIGMA is REAL array, dimension (N) !> Contains a copy of the diagonal elements (K-1 singular values !> and one zero) in the secular equation. !>
[out]	U2	!> U2 is REAL array, dimension (LDU2,N) !> Contains a copy of the first K-1 left singular vectors which !> will be used by SLASD3 in a matrix multiply (SGEMM) to solve !> for the new left singular vectors. U2 is arranged into four !> blocks. The first block contains a column with 1 at NL+1 and !> zero everywhere else; the second block contains non-zero !> entries only at and above NL; the third contains non-zero !> entries only below NL+1; and the fourth is dense. !>
[in]	LDU2	!> LDU2 is INTEGER !> The leading dimension of the array U2. LDU2 >= N. !>
[out]	VT2	!> VT2 is REAL array, dimension (LDVT2,N) !> VT2**T contains a copy of the first K right singular vectors !> which will be used by SLASD3 in a matrix multiply (SGEMM) to !> solve for the new right singular vectors. VT2 is arranged into !> three blocks. The first block contains a row that corresponds !> to the special 0 diagonal element in SIGMA; the second block !> contains non-zeros only at and before NL +1; the third block !> contains non-zeros only at and after NL +2. !>
[in]	LDVT2	!> LDVT2 is INTEGER !> The leading dimension of the array VT2. LDVT2 >= M. !>
[out]	IDXP	!> IDXP is INTEGER array, dimension (N) !> This will contain the permutation used to place deflated !> values of D at the end of the array. On output IDXP(2:K) !> points to the nondeflated D-values and IDXP(K+1:N) !> points to the deflated singular values. !>
[out]	IDX	!> IDX is INTEGER array, dimension (N) !> This will contain the permutation used to sort the contents of !> D into ascending order. !>
[out]	IDXC	!> IDXC is INTEGER array, dimension (N) !> This will contain the permutation used to arrange the columns !> of the deflated U matrix into three groups: the first group !> contains non-zero entries only at and above NL, the second !> contains non-zero entries only below NL+2, and the third is !> dense. !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension (N) !> This contains the permutation which separately sorts the two !> sub-problems in D into ascending order. Note that entries in !> the first hlaf of this permutation must first be moved one !> position backward; and entries in the second half !> must first have NL+1 added to their values. !>
[out]	COLTYP	!> COLTYP is INTEGER array, dimension (N) !> As workspace, this will contain a label which will indicate !> which of the following types a column in the U2 matrix or a !> row in the VT2 matrix is: !> 1 : non-zero in the upper half only !> 2 : non-zero in the lower half only !> 3 : dense !> 4 : deflated !> !> On exit, it is an array of dimension 4, with COLTYP(I) being !> the dimension of the I-th type columns. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 266 of file slasd2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      INTEGER            COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
     $                   IDXQ( * )
      REAL               D( * ), DSIGMA( * ), U( LDU, * ),
     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, EIGHT
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
     $                   eight = 8.0e+0 )
*     ..
*     .. Local Arrays ..
      INTEGER            CTOT( 4 ), PSM( 4 )
*     ..
*     .. Local Scalars ..
      INTEGER            CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
     $                   N, NLP1, NLP2
      REAL               C, EPS, HLFTOL, S, TAU, TOL, Z1
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLAPY2
      EXTERNAL           slamch, slapy2
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slacpy, slamrg, slaset, srot, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) ) THEN
         info = -3
      END IF
*
      n = nl + nr + 1
      m = n + sqre
*
      IF( ldu.LT.n ) THEN
         info = -10
      ELSE IF( ldvt.LT.m ) THEN
         info = -12
      ELSE IF( ldu2.LT.n ) THEN
         info = -15
      ELSE IF( ldvt2.LT.m ) THEN
         info = -17
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD2', -info )
         RETURN
      END IF
*
      nlp1 = nl + 1
      nlp2 = nl + 2
*
*     Generate the first part of the vector Z; and move the singular
*     values in the first part of D one position backward.
*
      z1 = alpha*vt( nlp1, nlp1 )
      z( 1 ) = z1
      DO 10 i = nl, 1, -1
         z( i+1 ) = alpha*vt( i, nlp1 )
         d( i+1 ) = d( i )
         idxq( i+1 ) = idxq( i ) + 1
   10 CONTINUE
*
*     Generate the second part of the vector Z.
*
      DO 20 i = nlp2, m
         z( i ) = beta*vt( i, nlp2 )
   20 CONTINUE
*
*     Initialize some reference arrays.
*
      DO 30 i = 2, nlp1
         coltyp( i ) = 1
   30 CONTINUE
      DO 40 i = nlp2, n
         coltyp( i ) = 2
   40 CONTINUE
*
*     Sort the singular values into increasing order
*
      DO 50 i = nlp2, n
         idxq( i ) = idxq( i ) + nlp1
   50 CONTINUE
*
*     DSIGMA, IDXC, IDXC, and the first column of U2
*     are used as storage space.
*
      DO 60 i = 2, n
         dsigma( i ) = d( idxq( i ) )
         u2( i, 1 ) = z( idxq( i ) )
         idxc( i ) = coltyp( idxq( i ) )
   60 CONTINUE
*
      CALL slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
*
      DO 70 i = 2, n
         idxi = 1 + idx( i )
         d( i ) = dsigma( idxi )
         z( i ) = u2( idxi, 1 )
         coltyp( i ) = idxc( idxi )
   70 CONTINUE
*
*     Calculate the allowable deflation tolerance
*
      eps = slamch( 'Epsilon' )
      tol = max( abs( alpha ), abs( beta ) )
      tol = eight*eps*max( abs( d( n ) ), tol )
*
*     There are 2 kinds of deflation -- first a value in the z-vector
*     is small, second two (or more) singular values are very close
*     together (their difference is small).
*
*     If the value in the z-vector is small, we simply permute the
*     array so that the corresponding singular value is moved to the
*     end.
*
*     If two values in the D-vector are close, we perform a two-sided
*     rotation designed to make one of the corresponding z-vector
*     entries zero, and then permute the array so that the deflated
*     singular value is moved to the end.
*
*     If there are multiple singular values then the problem deflates.
*     Here the number of equal singular values are found.  As each equal
*     singular value is found, an elementary reflector is computed to
*     rotate the corresponding singular subspace so that the
*     corresponding components of Z are zero in this new basis.
*
      k = 1
      k2 = n + 1
      DO 80 j = 2, n
         IF( abs( z( j ) ).LE.tol ) THEN
*
*           Deflate due to small z component.
*
            k2 = k2 - 1
            idxp( k2 ) = j
            coltyp( j ) = 4
            IF( j.EQ.n )
     $         GO TO 120
         ELSE
            jprev = j
            GO TO 90
         END IF
   80 CONTINUE
   90 CONTINUE
      j = jprev
  100 CONTINUE
      j = j + 1
      IF( j.GT.n )
     $   GO TO 110
      IF( abs( z( j ) ).LE.tol ) THEN
*
*        Deflate due to small z component.
*
         k2 = k2 - 1
         idxp( k2 ) = j
         coltyp( j ) = 4
      ELSE
*
*        Check if singular values are close enough to allow deflation.
*
         IF( abs( d( j )-d( jprev ) ).LE.tol ) THEN
*
*           Deflation is possible.
*
            s = z( jprev )
            c = z( j )
*
*           Find sqrt(a**2+b**2) without overflow or
*           destructive underflow.
*
            tau = slapy2( c, s )
            c = c / tau
            s = -s / tau
            z( j ) = tau
            z( jprev ) = zero
*
*           Apply back the Givens rotation to the left and right
*           singular vector matrices.
*
            idxjp = idxq( idx( jprev )+1 )
            idxj = idxq( idx( j )+1 )
            IF( idxjp.LE.nlp1 ) THEN
               idxjp = idxjp - 1
            END IF
            IF( idxj.LE.nlp1 ) THEN
               idxj = idxj - 1
            END IF
            CALL srot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s )
            CALL srot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,
     $                 s )
            IF( coltyp( j ).NE.coltyp( jprev ) ) THEN
               coltyp( j ) = 3
            END IF
            coltyp( jprev ) = 4
            k2 = k2 - 1
            idxp( k2 ) = jprev
            jprev = j
         ELSE
            k = k + 1
            u2( k, 1 ) = z( jprev )
            dsigma( k ) = d( jprev )
            idxp( k ) = jprev
            jprev = j
         END IF
      END IF
      GO TO 100
  110 CONTINUE
*
*     Record the last singular value.
*
      k = k + 1
      u2( k, 1 ) = z( jprev )
      dsigma( k ) = d( jprev )
      idxp( k ) = jprev
*
  120 CONTINUE
*
*     Count up the total number of the various types of columns, then
*     form a permutation which positions the four column types into
*     four groups of uniform structure (although one or more of these
*     groups may be empty).
*
      DO 130 j = 1, 4
         ctot( j ) = 0
  130 CONTINUE
      DO 140 j = 2, n
         ct = coltyp( j )
         ctot( ct ) = ctot( ct ) + 1
  140 CONTINUE
*
*     PSM(*) = Position in SubMatrix (of types 1 through 4)
*
      psm( 1 ) = 2
      psm( 2 ) = 2 + ctot( 1 )
      psm( 3 ) = psm( 2 ) + ctot( 2 )
      psm( 4 ) = psm( 3 ) + ctot( 3 )
*
*     Fill out the IDXC 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, starting from the
*     second column. This applies similarly to the rows of VT.
*
      DO 150 j = 2, n
         jp = idxp( j )
         ct = coltyp( jp )
         idxc( psm( ct ) ) = j
         psm( ct ) = psm( ct ) + 1
  150 CONTINUE
*
*     Sort the singular values and corresponding singular vectors into
*     DSIGMA, U2, and VT2 respectively.  The singular values/vectors
*     which were not deflated go into the first K slots of DSIGMA, U2,
*     and VT2 respectively, while those which were deflated go into the
*     last N - K slots, except that the first column/row will be treated
*     separately.
*
      DO 160 j = 2, n
         jp = idxp( j )
         dsigma( j ) = d( jp )
         idxj = idxq( idx( idxp( idxc( j ) ) )+1 )
         IF( idxj.LE.nlp1 ) THEN
            idxj = idxj - 1
         END IF
         CALL scopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 )
         CALL scopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 )
  160 CONTINUE
*
*     Determine DSIGMA(1), DSIGMA(2) and Z(1)
*
      dsigma( 1 ) = zero
      hlftol = tol / two
      IF( abs( dsigma( 2 ) ).LE.hlftol )
     $   dsigma( 2 ) = hlftol
      IF( m.GT.n ) THEN
         z( 1 ) = slapy2( z1, z( m ) )
         IF( z( 1 ).LE.tol ) THEN
            c = one
            s = zero
            z( 1 ) = tol
         ELSE
            c = z1 / z( 1 )
            s = z( m ) / z( 1 )
         END IF
      ELSE
         IF( abs( z1 ).LE.tol ) THEN
            z( 1 ) = tol
         ELSE
            z( 1 ) = z1
         END IF
      END IF
*
*     Move the rest of the updating row to Z.
*
      CALL scopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 )
*
*     Determine the first column of U2, the first row of VT2 and the
*     last row of VT.
*
      CALL slaset( 'A', n, 1, zero, zero, u2, ldu2 )
      u2( nlp1, 1 ) = one
      IF( m.GT.n ) THEN
         DO 170 i = 1, nlp1
            vt( m, i ) = -s*vt( nlp1, i )
            vt2( 1, i ) = c*vt( nlp1, i )
  170    CONTINUE
         DO 180 i = nlp2, m
            vt2( 1, i ) = s*vt( m, i )
            vt( m, i ) = c*vt( m, i )
  180    CONTINUE
      ELSE
         CALL scopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 )
      END IF
      IF( m.GT.n ) THEN
         CALL scopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 )
      END IF
*
*     The deflated singular values and their corresponding vectors go
*     into the back of D, U, and V respectively.
*
      IF( n.GT.k ) THEN
         CALL scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
         CALL slacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),
     $                ldu )
         CALL slacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),
     $                ldvt )
      END IF
*
*     Copy CTOT into COLTYP for referencing in SLASD3.
*
      DO 190 j = 1, 4
         coltyp( j ) = ctot( j )
  190 CONTINUE
*
      RETURN
*
*     End of SLASD2
*

slasd3()

subroutine slasd3	(	integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		real, dimension( * )	d,
		real, dimension( ldq, * )	q,
		integer	ldq,
		real, dimension( * )	dsigma,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldu2, * )	u2,
		integer	ldu2,
		real, dimension( ldvt, * )	vt,
		integer	ldvt,
		real, dimension( ldvt2, * )	vt2,
		integer	ldvt2,
		integer, dimension( * )	idxc,
		integer, dimension( * )	ctot,
		real, dimension( * )	z,
		integer	info )

SLASD3 finds all square roots of the roots of the secular equation, as defined by the values in D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc.

Download SLASD3 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD3 finds all the square roots of the roots of the secular
!> equation, as defined by the values in D and Z.  It makes the
!> appropriate calls to SLASD4 and then updates the singular
!> vectors by matrix multiplication.
!>
!> 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 XMP, Cray YMP, Cray C 90, or Cray 2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
!> SLASD3 is called from SLASD1.
!> 

Parameters

[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[in]	K	!> K is INTEGER !> The size of the secular equation, 1 =< K = < N. !>
[out]	D	!> D is REAL array, dimension(K) !> On exit the square roots of the roots of the secular equation, !> in ascending order. !>
[out]	Q	!> Q is REAL array, dimension (LDQ,K) !>
[in]	LDQ	!> LDQ is INTEGER !> The leading dimension of the array Q. LDQ >= K. !>
[in,out]	DSIGMA	!> DSIGMA is REAL array, dimension(K) !> The first K elements of this array contain the old roots !> of the deflated updating problem. These are the poles !> of the secular equation. !>
[out]	U	!> U is REAL array, dimension (LDU, N) !> The last N - K columns of this matrix contain the deflated !> left singular vectors. !>
[in]	LDU	!> LDU is INTEGER !> The leading dimension of the array U. LDU >= N. !>
[in]	U2	!> U2 is REAL array, dimension (LDU2, N) !> The first K columns of this matrix contain the non-deflated !> left singular vectors for the split problem. !>
[in]	LDU2	!> LDU2 is INTEGER !> The leading dimension of the array U2. LDU2 >= N. !>
[out]	VT	!> VT is REAL array, dimension (LDVT, M) !> The last M - K columns of VT**T contain the deflated !> right singular vectors. !>
[in]	LDVT	!> LDVT is INTEGER !> The leading dimension of the array VT. LDVT >= N. !>
[in,out]	VT2	!> VT2 is REAL array, dimension (LDVT2, N) !> The first K columns of VT2**T contain the non-deflated !> right singular vectors for the split problem. !>
[in]	LDVT2	!> LDVT2 is INTEGER !> The leading dimension of the array VT2. LDVT2 >= N. !>
[in]	IDXC	!> IDXC is INTEGER array, dimension (N) !> The permutation used to arrange the columns of U (and rows of !> VT) into three groups: the first group contains non-zero !> entries only at and above (or before) NL +1; the second !> contains non-zero entries only at and below (or after) NL+2; !> and the third is dense. The first column of U and the row of !> VT are treated separately, however. !> !> The rows of the singular vectors found by SLASD4 !> must be likewise permuted before the matrix multiplies can !> take place. !>
[in]	CTOT	!> CTOT is INTEGER array, dimension (4) !> A count of the total number of the various types of columns !> in U (or rows in VT), as described in IDXC. The fourth column !> type is any column which has been deflated. !>
[in,out]	Z	!> Z is REAL array, dimension (K) !> The first K elements of this array contain the components !> of the deflation-adjusted updating row vector. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 221 of file slasd3.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
     $                   SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            CTOT( * ), IDXC( * )
      REAL               D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
     $                   U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO, NEGONE
      parameter( one = 1.0e+0, zero = 0.0e+0,
     $                     negone = -1.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
      REAL               RHO, TEMP
*     ..
*     .. External Functions ..
      REAL               SLAMC3, SNRM2
      EXTERNAL           slamc3, snrm2
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, sgemm, slacpy, slascl, slasd4, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( nl.LT.1 ) THEN
         info = -1
      ELSE IF( nr.LT.1 ) THEN
         info = -2
      ELSE IF( ( sqre.NE.1 ) .AND. ( sqre.NE.0 ) ) THEN
         info = -3
      END IF
*
      n = nl + nr + 1
      m = n + sqre
      nlp1 = nl + 1
      nlp2 = nl + 2
*
      IF( ( k.LT.1 ) .OR. ( k.GT.n ) ) THEN
         info = -4
      ELSE IF( ldq.LT.k ) THEN
         info = -7
      ELSE IF( ldu.LT.n ) THEN
         info = -10
      ELSE IF( ldu2.LT.n ) THEN
         info = -12
      ELSE IF( ldvt.LT.m ) THEN
         info = -14
      ELSE IF( ldvt2.LT.m ) THEN
         info = -16
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD3', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( k.EQ.1 ) THEN
         d( 1 ) = abs( z( 1 ) )
         CALL scopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt )
         IF( z( 1 ).GT.zero ) THEN
            CALL scopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 )
         ELSE
            DO 10 i = 1, n
               u( i, 1 ) = -u2( i, 1 )
   10       CONTINUE
         END IF
         RETURN
      END IF
*
*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
*     which on any of these machines zeros out the bottommost
*     bit of DSIGMA(I) if it is 1; this makes the subsequent
*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
*     occurs. On binary machines with a guard digit (almost all
*     machines) it does not change DSIGMA(I) at all. On hexadecimal
*     and decimal machines with a guard digit, it slightly
*     changes the bottommost bits of DSIGMA(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*DSIGMA(I) to prevent optimizing compilers from eliminating
*     this code.
*
      DO 20 i = 1, k
         dsigma( i ) = slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
   20 CONTINUE
*
*     Keep a copy of Z.
*
      CALL scopy( k, z, 1, q, 1 )
*
*     Normalize Z.
*
      rho = snrm2( k, z, 1 )
      CALL slascl( 'G', 0, 0, rho, one, k, 1, z, k, info )
      rho = rho*rho
*
*     Find the new singular values.
*
      DO 30 j = 1, k
         CALL slasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),
     $                vt( 1, j ), info )
*
*        If the zero finder fails, report the convergence failure.
*
         IF( info.NE.0 ) THEN
            RETURN
         END IF
   30 CONTINUE
*
*     Compute updated Z.
*
      DO 60 i = 1, k
         z( i ) = u( i, k )*vt( i, k )
         DO 40 j = 1, i - 1
            z( i ) = z( i )*( u( i, j )*vt( i, j ) /
     $               ( dsigma( i )-dsigma( j ) ) /
     $               ( dsigma( i )+dsigma( j ) ) )
   40    CONTINUE
         DO 50 j = i, k - 1
            z( i ) = z( i )*( u( i, j )*vt( i, j ) /
     $               ( dsigma( i )-dsigma( j+1 ) ) /
     $               ( dsigma( i )+dsigma( j+1 ) ) )
   50    CONTINUE
         z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) )
   60 CONTINUE
*
*     Compute left singular vectors of the modified diagonal matrix,
*     and store related information for the right singular vectors.
*
      DO 90 i = 1, k
         vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i )
         u( 1, i ) = negone
         DO 70 j = 2, k
            vt( j, i ) = z( j ) / u( j, i ) / vt( j, i )
            u( j, i ) = dsigma( j )*vt( j, i )
   70    CONTINUE
         temp = snrm2( k, u( 1, i ), 1 )
         q( 1, i ) = u( 1, i ) / temp
         DO 80 j = 2, k
            jc = idxc( j )
            q( j, i ) = u( jc, i ) / temp
   80    CONTINUE
   90 CONTINUE
*
*     Update the left singular vector matrix.
*
      IF( k.EQ.2 ) THEN
         CALL sgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,
     $               ldu )
         GO TO 100
      END IF
      IF( ctot( 1 ).GT.0 ) THEN
         CALL sgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,
     $               q( 2, 1 ), ldq, zero, u( 1, 1 ), ldu )
         IF( ctot( 3 ).GT.0 ) THEN
            ktemp = 2 + ctot( 1 ) + ctot( 2 )
            CALL sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
     $                  ldu2, q( ktemp, 1 ), ldq, one, u( 1, 1 ), ldu )
         END IF
      ELSE IF( ctot( 3 ).GT.0 ) THEN
         ktemp = 2 + ctot( 1 ) + ctot( 2 )
         CALL sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),
     $               ldu2, q( ktemp, 1 ), ldq, zero, u( 1, 1 ), ldu )
      ELSE
         CALL slacpy( 'F', nl, k, u2, ldu2, u, ldu )
      END IF
      CALL scopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu )
      ktemp = 2 + ctot( 1 )
      ctemp = ctot( 2 ) + ctot( 3 )
      CALL sgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,
     $            q( ktemp, 1 ), ldq, zero, u( nlp2, 1 ), ldu )
*
*     Generate the right singular vectors.
*
  100 CONTINUE
      DO 120 i = 1, k
         temp = snrm2( k, vt( 1, i ), 1 )
         q( i, 1 ) = vt( 1, i ) / temp
         DO 110 j = 2, k
            jc = idxc( j )
            q( i, j ) = vt( jc, i ) / temp
  110    CONTINUE
  120 CONTINUE
*
*     Update the right singular vector matrix.
*
      IF( k.EQ.2 ) THEN
         CALL sgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,
     $               vt, ldvt )
         RETURN
      END IF
      ktemp = 1 + ctot( 1 )
      CALL sgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,
     $            vt2( 1, 1 ), ldvt2, zero, vt( 1, 1 ), ldvt )
      ktemp = 2 + ctot( 1 ) + ctot( 2 )
      IF( ktemp.LE.ldvt2 )
     $   CALL sgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),
     $               ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),
     $               ldvt )
*
      ktemp = ctot( 1 ) + 1
      nrp1 = nr + sqre
      IF( ktemp.GT.1 ) THEN
         DO 130 i = 1, k
            q( i, ktemp ) = q( i, 1 )
  130    CONTINUE
         DO 140 i = nlp2, m
            vt2( ktemp, i ) = vt2( 1, i )
  140    CONTINUE
      END IF
      ctemp = 1 + ctot( 2 ) + ctot( 3 )
      CALL sgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,
     $            vt2( ktemp, nlp2 ), ldvt2, zero, vt( 1, nlp2 ), ldvt )
*
      RETURN
*
*     End of SLASD3
*

slasd4()

subroutine slasd4	(	integer	n,
		integer	i,
		real, dimension( * )	d,
		real, dimension( * )	z,
		real, dimension( * )	delta,
		real	rho,
		real	sigma,
		real, dimension( * )	work,
		integer	info )

SLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one modification to a positive diagonal matrix. Used by sbdsdc.

Download SLASD4 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This subroutine computes the square root of the I-th updated
!> eigenvalue of a positive symmetric rank-one modification to
!> a positive diagonal matrix whose entries are given as the squares
!> of the corresponding entries in the array d, and that
!>
!>        0 <= 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 ) * 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.
!> 

Parameters

[in]	N	!> N is INTEGER !> The length of all arrays. !>
[in]	I	!> I is INTEGER !> The index of the eigenvalue to be computed. 1 <= I <= N. !>
[in]	D	!> D is REAL array, dimension ( N ) !> The original eigenvalues. It is assumed that they are in !> order, 0 <= D(I) < D(J) for I < J. !>
[in]	Z	!> Z is REAL array, dimension ( N ) !> The components of the updating vector. !>
[out]	DELTA	!> DELTA is REAL array, dimension ( N ) !> If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th !> component. If N = 1, then DELTA(1) = 1. The vector DELTA !> contains the information necessary to construct the !> (singular) eigenvectors. !>
[in]	RHO	!> RHO is REAL !> The scalar in the symmetric updating formula. !>
[out]	SIGMA	!> SIGMA is REAL !> The computed sigma_I, the I-th updated eigenvalue. !>
[out]	WORK	!> WORK is REAL array, dimension ( N ) !> If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th !> component. If N = 1, then WORK( 1 ) = 1. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> > 0: if INFO = 1, the updating process failed. !>

Internal Parameters:

!>  Logical variable ORGATI (origin-at-i?) is used for distinguishing
!>  whether D(i) or D(i+1) is treated as the origin.
!>
!>            ORGATI = .true.    origin at i
!>            ORGATI = .false.   origin at i+1
!>
!>  Logical variable SWTCH3 (switch-for-3-poles?) is for noting
!>  if we are working with THREE poles!
!>
!>  MAXIT is the maximum number of iterations allowed for each
!>  eigenvalue.
!> 

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 152 of file slasd4.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            I, INFO, N
      REAL   RHO, SIGMA
*     ..
*     .. Array Arguments ..
      REAL   D( * ), DELTA( * ), WORK( * ), Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            MAXIT
      parameter( maxit = 400 )
      REAL               ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
     $                   three = 3.0e+0, four = 4.0e+0, eight = 8.0e+0,
     $                   ten = 10.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ORGATI, SWTCH, SWTCH3, GEOMAVG
      INTEGER            II, IIM1, IIP1, IP1, ITER, J, NITER
      REAL               A, B, C, DELSQ, DELSQ2, SQ2, DPHI, DPSI, DTIIM,
     $                   DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
     $                   ERRETM, ETA, PHI, PREW, PSI, RHOINV, SGLB,
     $                   SGUB, TAU, TAU2, TEMP, TEMP1, TEMP2, W
*     ..
*     .. Local Arrays ..
      REAL               DD( 3 ), ZZ( 3 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           slaed6, slasd5
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, sqrt
*     ..
*     .. 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
      IF( n.EQ.1 ) THEN
*
*        Presumably, I=1 upon entry
*
         sigma = sqrt( d( 1 )*d( 1 )+rho*z( 1 )*z( 1 ) )
         delta( 1 ) = one
         work( 1 ) = one
         RETURN
      END IF
      IF( n.EQ.2 ) THEN
         CALL slasd5( i, d, z, delta, rho, sigma, work )
         RETURN
      END IF
*
*     Compute machine epsilon
*
      eps = slamch( 'Epsilon' )
      rhoinv = one / rho
      tau2= zero
*
*     The case I = N
*
      IF( i.EQ.n ) THEN
*
*        Initialize some basic variables
*
         ii = n - 1
         niter = 1
*
*        Calculate initial guess
*
         temp = rho / two
*
*        If ||Z||_2 is not one, then TEMP should be set to
*        RHO * ||Z||_2^2 / TWO
*
         temp1 = temp / ( d( n )+sqrt( d( n )*d( n )+temp ) )
         DO 10 j = 1, n
            work( j ) = d( j ) + d( n ) + temp1
            delta( j ) = ( d( j )-d( n ) ) - temp1
   10    CONTINUE
*
         psi = zero
         DO 20 j = 1, n - 2
            psi = psi + z( j )*z( j ) / ( delta( j )*work( j ) )
   20    CONTINUE
*
         c = rhoinv + psi
         w = c + z( ii )*z( ii ) / ( delta( ii )*work( ii ) ) +
     $       z( n )*z( n ) / ( delta( n )*work( n ) )
*
         IF( w.LE.zero ) THEN
            temp1 = sqrt( d( n )*d( n )+rho )
            temp = z( n-1 )*z( n-1 ) / ( ( d( n-1 )+temp1 )*
     $             ( d( n )-d( n-1 )+rho / ( d( n )+temp1 ) ) ) +
     $             z( n )*z( n ) / rho
*
*           The following TAU2 is to approximate
*           SIGMA_n^2 - D( N )*D( N )
*
            IF( c.LE.temp ) THEN
               tau = rho
            ELSE
               delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) )
               a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n )
               b = z( n )*z( n )*delsq
               IF( a.LT.zero ) THEN
                  tau2 = two*b / ( sqrt( a*a+four*b*c )-a )
               ELSE
                  tau2 = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
               END IF
               tau = tau2 / ( d( n )+sqrt( d( n )*d( n )+tau2 ) )
            END IF
*
*           It can be proved that
*               D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO
*
         ELSE
            delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) )
            a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n )
            b = z( n )*z( n )*delsq
*
*           The following TAU2 is to approximate
*           SIGMA_n^2 - D( N )*D( N )
*
            IF( a.LT.zero ) THEN
               tau2 = two*b / ( sqrt( a*a+four*b*c )-a )
            ELSE
               tau2 = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
            END IF
            tau = tau2 / ( d( n )+sqrt( d( n )*d( n )+tau2 ) )
 
*
*           It can be proved that
*           D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2
*
         END IF
*
*        The following TAU is to approximate SIGMA_n - D( N )
*
*         TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) )
*
         sigma = d( n ) + tau
         DO 30 j = 1, n
            delta( j ) = ( d( j )-d( n ) ) - tau
            work( j ) = d( j ) + d( n ) + tau
   30    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 40 j = 1, ii
            temp = z( j ) / ( delta( j )*work( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
   40    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         temp = z( n ) / ( delta( n )*work( n ) )
         phi = z( n )*temp
         dphi = temp*temp
         erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $          + ABS( TAU2 )*( DPSI+DPHI )
*
         w = rhoinv + phi + psi
*
*        Test for convergence
*
         IF( abs( w ).LE.eps*erretm ) THEN
            GO TO 240
         END IF
*
*        Calculate the new step
*
         niter = niter + 1
         dtnsq1 = work( n-1 )*delta( n-1 )
         dtnsq = work( n )*delta( n )
         c = w - dtnsq1*dpsi - dtnsq*dphi
         a = ( dtnsq+dtnsq1 )*w - dtnsq*dtnsq1*( dpsi+dphi )
         b = dtnsq*dtnsq1*w
         IF( c.LT.zero )
     $      c = abs( c )
         IF( c.EQ.zero ) THEN
            eta = rho - sigma*sigma
         ELSE IF( a.GE.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.GT.zero )
     $      eta = -w / ( dpsi+dphi )
         temp = eta - dtnsq
         IF( temp.GT.rho )
     $      eta = rho + dtnsq
*
         eta = eta / ( sigma+sqrt( eta+sigma*sigma ) )
         tau = tau + eta
         sigma = sigma + eta
*
         DO 50 j = 1, n
            delta( j ) = delta( j ) - eta
            work( j ) = work( j ) + eta
   50    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 60 j = 1, ii
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
   60    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         tau2 = work( n )*delta( n )
         temp = z( n ) / tau2
         phi = z( n )*temp
         dphi = temp*temp
         erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $          + ABS( TAU2 )*( DPSI+DPHI )
*
         w = rhoinv + phi + psi
*
*        Main loop to update the values of the array   DELTA
*
         iter = niter + 1
*
         DO 90 niter = iter, maxit
*
*           Test for convergence
*
            IF( abs( w ).LE.eps*erretm ) THEN
               GO TO 240
            END IF
*
*           Calculate the new step
*
            dtnsq1 = work( n-1 )*delta( n-1 )
            dtnsq = work( n )*delta( n )
            c = w - dtnsq1*dpsi - dtnsq*dphi
            a = ( dtnsq+dtnsq1 )*w - dtnsq1*dtnsq*( dpsi+dphi )
            b = dtnsq1*dtnsq*w
            IF( a.GE.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.GT.zero )
     $         eta = -w / ( dpsi+dphi )
            temp = eta - dtnsq
            IF( temp.LE.zero )
     $         eta = eta / two
*
            eta = eta / ( sigma+sqrt( eta+sigma*sigma ) )
            tau = tau + eta
            sigma = sigma + eta
*
            DO 70 j = 1, n
               delta( j ) = delta( j ) - eta
               work( j ) = work( j ) + eta
   70       CONTINUE
*
*           Evaluate PSI and the derivative DPSI
*
            dpsi = zero
            psi = zero
            erretm = zero
            DO 80 j = 1, ii
               temp = z( j ) / ( work( j )*delta( j ) )
               psi = psi + z( j )*temp
               dpsi = dpsi + temp*temp
               erretm = erretm + psi
   80       CONTINUE
            erretm = abs( erretm )
*
*           Evaluate PHI and the derivative DPHI
*
            tau2 = work( n )*delta( n )
            temp = z( n ) / tau2
            phi = z( n )*temp
            dphi = temp*temp
            erretm = eight*( -phi-psi ) + erretm - phi + rhoinv
*    $             + ABS( TAU2 )*( DPSI+DPHI )
*
            w = rhoinv + phi + psi
   90    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         info = 1
         GO TO 240
*
*        End for the case I = N
*
      ELSE
*
*        The case for I < N
*
         niter = 1
         ip1 = i + 1
*
*        Calculate initial guess
*
         delsq = ( d( ip1 )-d( i ) )*( d( ip1 )+d( i ) )
         delsq2 = delsq / two
         sq2=sqrt( ( d( i )*d( i )+d( ip1 )*d( ip1 ) ) / two )
         temp = delsq2 / ( d( i )+sq2 )
         DO 100 j = 1, n
            work( j ) = d( j ) + d( i ) + temp
            delta( j ) = ( d( j )-d( i ) ) - temp
  100    CONTINUE
*
         psi = zero
         DO 110 j = 1, i - 1
            psi = psi + z( j )*z( j ) / ( work( j )*delta( j ) )
  110    CONTINUE
*
         phi = zero
         DO 120 j = n, i + 2, -1
            phi = phi + z( j )*z( j ) / ( work( j )*delta( j ) )
  120    CONTINUE
         c = rhoinv + psi + phi
         w = c + z( i )*z( i ) / ( work( i )*delta( i ) ) +
     $       z( ip1 )*z( ip1 ) / ( work( ip1 )*delta( ip1 ) )
*
         geomavg = .false.
         IF( w.GT.zero ) THEN
*
*           d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
*
*           We choose d(i) as origin.
*
            orgati = .true.
            ii = i
            sglb = zero
            sgub = delsq2  / ( d( i )+sq2 )
            a = c*delsq + z( i )*z( i ) + z( ip1 )*z( ip1 )
            b = z( i )*z( i )*delsq
            IF( a.GT.zero ) THEN
               tau2 = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
            ELSE
               tau2 = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
            END IF
*
*           TAU2 now is an estimation of SIGMA^2 - D( I )^2. The
*           following, however, is the corresponding estimation of
*           SIGMA - D( I ).
*
            tau = tau2 / ( d( i )+sqrt( d( i )*d( i )+tau2 ) )
            temp = sqrt(eps)
            IF( (d(i).LE.temp*d(ip1)).AND.(abs(z(i)).LE.temp)
     $                               .AND.(d(i).GT.zero) ) THEN
               tau = min( ten*d(i), sgub )
               geomavg = .true.
            END IF
         ELSE
*
*           (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
*
*           We choose d(i+1) as origin.
*
            orgati = .false.
            ii = ip1
            sglb = -delsq2  / ( d( ii )+sq2 )
            sgub = zero
            a = c*delsq - z( i )*z( i ) - z( ip1 )*z( ip1 )
            b = z( ip1 )*z( ip1 )*delsq
            IF( a.LT.zero ) THEN
               tau2 = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
            ELSE
               tau2 = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
            END IF
*
*           TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The
*           following, however, is the corresponding estimation of
*           SIGMA - D( IP1 ).
*
            tau = tau2 / ( d( ip1 )+sqrt( abs( d( ip1 )*d( ip1 )+
     $            tau2 ) ) )
         END IF
*
         sigma = d( ii ) + tau
         DO 130 j = 1, n
            work( j ) = d( j ) + d( ii ) + tau
            delta( j ) = ( d( j )-d( ii ) ) - tau
  130    CONTINUE
         iim1 = ii - 1
         iip1 = ii + 1
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 150 j = 1, iim1
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
  150    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         dphi = zero
         phi = zero
         DO 160 j = n, iip1, -1
            temp = z( j ) / ( work( j )*delta( j ) )
            phi = phi + z( j )*temp
            dphi = dphi + temp*temp
            erretm = erretm + phi
  160    CONTINUE
*
         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.LT.zero )
     $         swtch3 = .true.
         ELSE
            IF( w.GT.zero )
     $         swtch3 = .true.
         END IF
         IF( ii.EQ.1 .OR. ii.EQ.n )
     $      swtch3 = .false.
*
         temp = z( ii ) / ( work( 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( TAU2 )*DW
*
*        Test for convergence
*
         IF( abs( w ).LE.eps*erretm ) THEN
            GO TO 240
         END IF
*
         IF( w.LE.zero ) THEN
            sglb = max( sglb, tau )
         ELSE
            sgub = min( sgub, tau )
         END IF
*
*        Calculate the new step
*
         niter = niter + 1
         IF( .NOT.swtch3 ) THEN
            dtipsq = work( ip1 )*delta( ip1 )
            dtisq = work( i )*delta( i )
            IF( orgati ) THEN
               c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
            ELSE
               c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
            END IF
            a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
            b = dtipsq*dtisq*w
            IF( c.EQ.zero ) THEN
               IF( a.EQ.zero ) THEN
                  IF( orgati ) THEN
                     a = z( i )*z( i ) + dtipsq*dtipsq*( dpsi+dphi )
                  ELSE
                     a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi )
                  END IF
               END IF
               eta = b / a
            ELSE IF( a.LE.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
*
            dtiim = work( iim1 )*delta( iim1 )
            dtiip = work( iip1 )*delta( iip1 )
            temp = rhoinv + psi + phi
            IF( orgati ) THEN
               temp1 = z( iim1 ) / dtiim
               temp1 = temp1*temp1
               c = ( temp - dtiip*( dpsi+dphi ) ) -
     $             ( d( iim1 )-d( iip1 ) )*( d( iim1 )+d( iip1 ) )*temp1
               zz( 1 ) = z( iim1 )*z( iim1 )
               IF( dpsi.LT.temp1 ) THEN
                  zz( 3 ) = dtiip*dtiip*dphi
               ELSE
                  zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi )
               END IF
            ELSE
               temp1 = z( iip1 ) / dtiip
               temp1 = temp1*temp1
               c = ( temp - dtiim*( dpsi+dphi ) ) -
     $             ( d( iip1 )-d( iim1 ) )*( d( iim1 )+d( iip1 ) )*temp1
               IF( dphi.LT.temp1 ) THEN
                  zz( 1 ) = dtiim*dtiim*dpsi
               ELSE
                  zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) )
               END IF
               zz( 3 ) = z( iip1 )*z( iip1 )
            END IF
            zz( 2 ) = z( ii )*z( ii )
            dd( 1 ) = dtiim
            dd( 2 ) = delta( ii )*work( ii )
            dd( 3 ) = dtiip
            CALL slaed6( niter, orgati, c, dd, zz, w, eta, info )
*
            IF( info.NE.0 ) THEN
*
*              If INFO is not 0, i.e., SLAED6 failed, switch back
*              to 2 pole interpolation.
*
               swtch3 = .false.
               info = 0
               dtipsq = work( ip1 )*delta( ip1 )
               dtisq = work( i )*delta( i )
               IF( orgati ) THEN
                  c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
               ELSE
                  c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
               END IF
               a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
               b = dtipsq*dtisq*w
               IF( c.EQ.zero ) THEN
                  IF( a.EQ.zero ) THEN
                     IF( orgati ) THEN
                        a = z( i )*z( i ) + dtipsq*dtipsq*( dpsi+dphi )
                     ELSE
                        a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi)
                     END IF
                  END IF
                  eta = b / a
               ELSE IF( a.LE.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
            END IF
         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.GE.zero )
     $      eta = -w / dw
*
         eta = eta / ( sigma+sqrt( sigma*sigma+eta ) )
         temp = tau + eta
         IF( temp.GT.sgub .OR. temp.LT.sglb ) THEN
            IF( w.LT.zero ) THEN
               eta = ( sgub-tau ) / two
            ELSE
               eta = ( sglb-tau ) / two
            END IF
            IF( geomavg ) THEN
               IF( w .LT. zero ) THEN
                  IF( tau .GT. zero ) THEN
                     eta = sqrt(sgub*tau)-tau
                  END IF
               ELSE
                  IF( sglb .GT. zero ) THEN
                     eta = sqrt(sglb*tau)-tau
                  END IF
               END IF
            END IF
         END IF
*
         prew = w
*
         tau = tau + eta
         sigma = sigma + eta
*
         DO 170 j = 1, n
            work( j ) = work( j ) + eta
            delta( j ) = delta( j ) - eta
  170    CONTINUE
*
*        Evaluate PSI and the derivative DPSI
*
         dpsi = zero
         psi = zero
         erretm = zero
         DO 180 j = 1, iim1
            temp = z( j ) / ( work( j )*delta( j ) )
            psi = psi + z( j )*temp
            dpsi = dpsi + temp*temp
            erretm = erretm + psi
  180    CONTINUE
         erretm = abs( erretm )
*
*        Evaluate PHI and the derivative DPHI
*
         dphi = zero
         phi = zero
         DO 190 j = n, iip1, -1
            temp = z( j ) / ( work( j )*delta( j ) )
            phi = phi + z( j )*temp
            dphi = dphi + temp*temp
            erretm = erretm + phi
  190    CONTINUE
*
         tau2 = work( ii )*delta( ii )
         temp = z( ii ) / tau2
         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( TAU2 )*DW
*
         swtch = .false.
         IF( orgati ) THEN
            IF( -w.GT.abs( prew ) / ten )
     $         swtch = .true.
         ELSE
            IF( w.GT.abs( prew ) / ten )
     $         swtch = .true.
         END IF
*
*        Main loop to update the values of the array   DELTA and WORK
*
         iter = niter + 1
*
         DO 230 niter = iter, maxit
*
*           Test for convergence
*
            IF( abs( w ).LE.eps*erretm ) THEN
*     $          .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN
               GO TO 240
            END IF
*
            IF( w.LE.zero ) THEN
               sglb = max( sglb, tau )
            ELSE
               sgub = min( sgub, tau )
            END IF
*
*           Calculate the new step
*
            IF( .NOT.swtch3 ) THEN
               dtipsq = work( ip1 )*delta( ip1 )
               dtisq = work( i )*delta( i )
               IF( .NOT.swtch ) THEN
                  IF( orgati ) THEN
                     c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2
                  ELSE
                     c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2
                  END IF
               ELSE
                  temp = z( ii ) / ( work( ii )*delta( ii ) )
                  IF( orgati ) THEN
                     dpsi = dpsi + temp*temp
                  ELSE
                     dphi = dphi + temp*temp
                  END IF
                  c = w - dtisq*dpsi - dtipsq*dphi
               END IF
               a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
               b = dtipsq*dtisq*w
               IF( c.EQ.zero ) THEN
                  IF( a.EQ.zero ) THEN
                     IF( .NOT.swtch ) THEN
                        IF( orgati ) THEN
                           a = z( i )*z( i ) + dtipsq*dtipsq*
     $                         ( dpsi+dphi )
                        ELSE
                           a = z( ip1 )*z( ip1 ) +
     $                         dtisq*dtisq*( dpsi+dphi )
                        END IF
                     ELSE
                        a = dtisq*dtisq*dpsi + dtipsq*dtipsq*dphi
                     END IF
                  END IF
                  eta = b / a
               ELSE IF( a.LE.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
*
               dtiim = work( iim1 )*delta( iim1 )
               dtiip = work( iip1 )*delta( iip1 )
               temp = rhoinv + psi + phi
               IF( swtch ) THEN
                  c = temp - dtiim*dpsi - dtiip*dphi
                  zz( 1 ) = dtiim*dtiim*dpsi
                  zz( 3 ) = dtiip*dtiip*dphi
               ELSE
                  IF( orgati ) THEN
                     temp1 = z( iim1 ) / dtiim
                     temp1 = temp1*temp1
                     temp2 = ( d( iim1 )-d( iip1 ) )*
     $                       ( d( iim1 )+d( iip1 ) )*temp1
                     c = temp - dtiip*( dpsi+dphi ) - temp2
                     zz( 1 ) = z( iim1 )*z( iim1 )
                     IF( dpsi.LT.temp1 ) THEN
                        zz( 3 ) = dtiip*dtiip*dphi
                     ELSE
                        zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi )
                     END IF
                  ELSE
                     temp1 = z( iip1 ) / dtiip
                     temp1 = temp1*temp1
                     temp2 = ( d( iip1 )-d( iim1 ) )*
     $                       ( d( iim1 )+d( iip1 ) )*temp1
                     c = temp - dtiim*( dpsi+dphi ) - temp2
                     IF( dphi.LT.temp1 ) THEN
                        zz( 1 ) = dtiim*dtiim*dpsi
                     ELSE
                        zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) )
                     END IF
                     zz( 3 ) = z( iip1 )*z( iip1 )
                  END IF
               END IF
               dd( 1 ) = dtiim
               dd( 2 ) = delta( ii )*work( ii )
               dd( 3 ) = dtiip
               CALL slaed6( niter, orgati, c, dd, zz, w, eta, info )
*
               IF( info.NE.0 ) THEN
*
*                 If INFO is not 0, i.e., SLAED6 failed, switch
*                 back to two pole interpolation
*
                  swtch3 = .false.
                  info = 0
                  dtipsq = work( ip1 )*delta( ip1 )
                  dtisq = work( i )*delta( i )
                  IF( .NOT.swtch ) THEN
                     IF( orgati ) THEN
                        c = w - dtipsq*dw + delsq*( z( i )/dtisq )**2
                     ELSE
                        c = w - dtisq*dw - delsq*( z( ip1 )/dtipsq )**2
                     END IF
                  ELSE
                     temp = z( ii ) / ( work( ii )*delta( ii ) )
                     IF( orgati ) THEN
                        dpsi = dpsi + temp*temp
                     ELSE
                        dphi = dphi + temp*temp
                     END IF
                     c = w - dtisq*dpsi - dtipsq*dphi
                  END IF
                  a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw
                  b = dtipsq*dtisq*w
                  IF( c.EQ.zero ) THEN
                     IF( a.EQ.zero ) THEN
                        IF( .NOT.swtch ) THEN
                           IF( orgati ) THEN
                              a = z( i )*z( i ) + dtipsq*dtipsq*
     $                            ( dpsi+dphi )
                           ELSE
                              a = z( ip1 )*z( ip1 ) +
     $                            dtisq*dtisq*( dpsi+dphi )
                           END IF
                        ELSE
                           a = dtisq*dtisq*dpsi + dtipsq*dtipsq*dphi
                        END IF
                     END IF
                     eta = b / a
                  ELSE IF( a.LE.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
               END IF
            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.GE.zero )
     $         eta = -w / dw
*
            eta = eta / ( sigma+sqrt( sigma*sigma+eta ) )
            temp=tau+eta
            IF( temp.GT.sgub .OR. temp.LT.sglb ) THEN
               IF( w.LT.zero ) THEN
                  eta = ( sgub-tau ) / two
               ELSE
                  eta = ( sglb-tau ) / two
               END IF
               IF( geomavg ) THEN
                  IF( w .LT. zero ) THEN
                     IF( tau .GT. zero ) THEN
                        eta = sqrt(sgub*tau)-tau
                     END IF
                  ELSE
                     IF( sglb .GT. zero ) THEN
                        eta = sqrt(sglb*tau)-tau
                     END IF
                  END IF
               END IF
            END IF
*
            prew = w
*
            tau = tau + eta
            sigma = sigma + eta
*
            DO 200 j = 1, n
               work( j ) = work( j ) + eta
               delta( j ) = delta( j ) - eta
  200       CONTINUE
*
*           Evaluate PSI and the derivative DPSI
*
            dpsi = zero
            psi = zero
            erretm = zero
            DO 210 j = 1, iim1
               temp = z( j ) / ( work( j )*delta( j ) )
               psi = psi + z( j )*temp
               dpsi = dpsi + temp*temp
               erretm = erretm + psi
  210       CONTINUE
            erretm = abs( erretm )
*
*           Evaluate PHI and the derivative DPHI
*
            dphi = zero
            phi = zero
            DO 220 j = n, iip1, -1
               temp = z( j ) / ( work( j )*delta( j ) )
               phi = phi + z( j )*temp
               dphi = dphi + temp*temp
               erretm = erretm + phi
  220       CONTINUE
*
            tau2 = work( ii )*delta( ii )
            temp = z( ii ) / tau2
            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( TAU2 )*DW
*
            IF( w*prew.GT.zero .AND. abs( w ).GT.abs( prew ) / ten )
     $         swtch = .NOT.swtch
*
  230    CONTINUE
*
*        Return with INFO = 1, NITER = MAXIT and not converged
*
         info = 1
*
      END IF
*
  240 CONTINUE
      RETURN
*
*     End of SLASD4
*

slasd5()

subroutine slasd5	(	integer	i,
		real, dimension( 2 )	d,
		real, dimension( 2 )	z,
		real, dimension( 2 )	delta,
		real	rho,
		real	dsigma,
		real, dimension( 2 )	work )

SLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modification of a 2-by-2 diagonal matrix. Used by sbdsdc.

Download SLASD5 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> This subroutine computes the square root of the I-th eigenvalue
!> of a positive symmetric rank-one modification of a 2-by-2 diagonal
!> matrix
!>
!>            diag( D ) * diag( D ) +  RHO * Z * transpose(Z) .
!>
!> The diagonal entries in the array D are assumed to satisfy
!>
!>            0 <= D(i) < D(j)  for  i < j .
!>
!> We also assume RHO > 0 and that the Euclidean norm of the vector
!> Z is one.
!> 

Parameters

[in]	I	!> I is INTEGER !> The index of the eigenvalue to be computed. I = 1 or I = 2. !>
[in]	D	!> D is REAL array, dimension (2) !> The original eigenvalues. We assume 0 <= D(1) < D(2). !>
[in]	Z	!> Z is REAL array, dimension (2) !> The components of the updating vector. !>
[out]	DELTA	!> DELTA is REAL array, dimension (2) !> Contains (D(j) - sigma_I) in its j-th component. !> The vector DELTA contains the information necessary !> to construct the eigenvectors. !>
[in]	RHO	!> RHO is REAL !> The scalar in the symmetric updating formula. !>
[out]	DSIGMA	!> DSIGMA is REAL !> The computed sigma_I, the I-th updated eigenvalue. !>
[out]	WORK	!> WORK is REAL array, dimension (2) !> WORK contains (D(j) + sigma_I) in its j-th component. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 115 of file slasd5.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            I
      REAL               DSIGMA, RHO
*     ..
*     .. Array Arguments ..
      REAL               D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, THREE, FOUR
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
     $                   three = 3.0e+0, four = 4.0e+0 )
*     ..
*     .. Local Scalars ..
      REAL               B, C, DEL, DELSQ, TAU, W
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sqrt
*     ..
*     .. Executable Statements ..
*
      del = d( 2 ) - d( 1 )
      delsq = del*( d( 2 )+d( 1 ) )
      IF( i.EQ.1 ) THEN
         w = one + four*rho*( z( 2 )*z( 2 ) / ( d( 1 )+three*d( 2 ) )-
     $       z( 1 )*z( 1 ) / ( three*d( 1 )+d( 2 ) ) ) / del
         IF( w.GT.zero ) THEN
            b = delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
            c = rho*z( 1 )*z( 1 )*delsq
*
*           B > ZERO, always
*
*           The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
*
            tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
*
*           The following TAU is DSIGMA - D( 1 )
*
            tau = tau / ( d( 1 )+sqrt( d( 1 )*d( 1 )+tau ) )
            dsigma = d( 1 ) + tau
            delta( 1 ) = -tau
            delta( 2 ) = del - tau
            work( 1 ) = two*d( 1 ) + tau
            work( 2 ) = ( d( 1 )+tau ) + d( 2 )
*           DELTA( 1 ) = -Z( 1 ) / TAU
*           DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
         ELSE
            b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
            c = rho*z( 2 )*z( 2 )*delsq
*
*           The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
            IF( b.GT.zero ) THEN
               tau = -two*c / ( b+sqrt( b*b+four*c ) )
            ELSE
               tau = ( b-sqrt( b*b+four*c ) ) / two
            END IF
*
*           The following TAU is DSIGMA - D( 2 )
*
            tau = tau / ( d( 2 )+sqrt( abs( d( 2 )*d( 2 )+tau ) ) )
            dsigma = d( 2 ) + tau
            delta( 1 ) = -( del+tau )
            delta( 2 ) = -tau
            work( 1 ) = d( 1 ) + tau + d( 2 )
            work( 2 ) = two*d( 2 ) + tau
*           DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
*           DELTA( 2 ) = -Z( 2 ) / TAU
         END IF
*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
*        DELTA( 1 ) = DELTA( 1 ) / TEMP
*        DELTA( 2 ) = DELTA( 2 ) / TEMP
      ELSE
*
*        Now I=2
*
         b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
         c = rho*z( 2 )*z( 2 )*delsq
*
*        The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
*
         IF( b.GT.zero ) THEN
            tau = ( b+sqrt( b*b+four*c ) ) / two
         ELSE
            tau = two*c / ( -b+sqrt( b*b+four*c ) )
         END IF
*
*        The following TAU is DSIGMA - D( 2 )
*
         tau = tau / ( d( 2 )+sqrt( d( 2 )*d( 2 )+tau ) )
         dsigma = d( 2 ) + tau
         delta( 1 ) = -( del+tau )
         delta( 2 ) = -tau
         work( 1 ) = d( 1 ) + tau + d( 2 )
         work( 2 ) = two*d( 2 ) + tau
*        DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
*        DELTA( 2 ) = -Z( 2 ) / TAU
*        TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
*        DELTA( 1 ) = DELTA( 1 ) / TEMP
*        DELTA( 2 ) = DELTA( 2 ) / TEMP
      END IF
      RETURN
*
*     End of SLASD5
*

slasd6()

subroutine slasd6	(	integer	icompq,
		integer	nl,
		integer	nr,
		integer	sqre,
		real, dimension( * )	d,
		real, dimension( * )	vf,
		real, dimension( * )	vl,
		real	alpha,
		real	beta,
		integer, dimension( * )	idxq,
		integer, dimension( * )	perm,
		integer	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		real, dimension( ldgnum, * )	givnum,
		integer	ldgnum,
		real, dimension( ldgnum, * )	poles,
		real, dimension( * )	difl,
		real, dimension( * )	difr,
		real, dimension( * )	z,
		integer	k,
		real	c,
		real	s,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

SLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller ones by appending a row. Used by sbdsdc.

Download SLASD6 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD6 computes the SVD of an updated upper bidiagonal matrix B
!> obtained by merging two smaller ones by appending a row. This
!> routine is used only for the problem which requires all singular
!> values and optionally singular vector matrices in factored form.
!> B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
!> A related subroutine, SLASD1, handles the case in which all singular
!> values and singular vectors of the bidiagonal matrix are desired.
!>
!> SLASD6 computes the SVD as follows:
!>
!>               ( D1(in)    0    0       0 )
!>   B = U(in) * (   Z1**T   a   Z2**T    b ) * VT(in)
!>               (   0       0   D2(in)   0 )
!>
!>     = U(out) * ( D(out) 0) * VT(out)
!>
!> where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M
!> with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
!> elsewhere; and the entry b is empty if SQRE = 0.
!>
!> The singular values of B can be computed using D1, D2, the first
!> components of all the right singular vectors of the lower block, and
!> the last components of all the right singular vectors of the upper
!> block. These components are stored and updated in VF and VL,
!> respectively, in SLASD6. Hence U and VT are not explicitly
!> referenced.
!>
!> The singular values are stored in D. The algorithm consists of two
!> stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple singular values 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 SLASD7.
!>
!>       The second stage consists of calculating the updated
!>       singular values. This is done by finding the roots of the
!>       secular equation via the routine SLASD4 (as called by SLASD8).
!>       This routine also updates VF and VL and computes the distances
!>       between the updated singular values and the old singular
!>       values.
!>
!> SLASD6 is called from SLASDA.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed in !> factored form: !> = 0: Compute singular values only. !> = 1: Compute singular vectors in factored form as well. !>
[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has row dimension N = NL + NR + 1, !> and column dimension M = N + SQRE. !>
[in,out]	D	!> D is REAL array, dimension (NL+NR+1). !> On entry D(1:NL,1:NL) contains the singular values of the !> upper block, and D(NL+2:N) contains the singular values !> of the lower block. On exit D(1:N) contains the singular !> values of the modified matrix. !>
[in,out]	VF	!> VF is REAL array, dimension (M) !> On entry, VF(1:NL+1) contains the first components of all !> right singular vectors of the upper block; and VF(NL+2:M) !> contains the first components of all right singular vectors !> of the lower block. On exit, VF contains the first components !> of all right singular vectors of the bidiagonal matrix. !>
[in,out]	VL	!> VL is REAL array, dimension (M) !> On entry, VL(1:NL+1) contains the last components of all !> right singular vectors of the upper block; and VL(NL+2:M) !> contains the last components of all right singular vectors of !> the lower block. On exit, VL contains the last components of !> all right singular vectors of the bidiagonal matrix. !>
[in,out]	ALPHA	!> ALPHA is REAL !> Contains the diagonal element associated with the added row. !>
[in,out]	BETA	!> BETA is REAL !> Contains the off-diagonal element associated with the added !> row. !>
[in,out]	IDXQ	!> IDXQ is INTEGER array, dimension (N) !> This contains the permutation which will reintegrate the !> subproblem just solved back into sorted order, i.e. !> D( IDXQ( I = 1, N ) ) will be in ascending order. !>
[out]	PERM	!> PERM is INTEGER array, dimension ( N ) !> The permutations (from deflation and sorting) to be applied !> to each block. Not referenced if ICOMPQ = 0. !>
[out]	GIVPTR	!> GIVPTR is INTEGER !> The number of Givens rotations which took place in this !> subproblem. Not referenced if ICOMPQ = 0. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGCOL	!> LDGCOL is INTEGER !> leading dimension of GIVCOL, must be at least N. !>
[out]	GIVNUM	!> GIVNUM is REAL array, dimension ( LDGNUM, 2 ) !> Each number indicates the C or S value to be used in the !> corresponding Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGNUM	!> LDGNUM is INTEGER !> The leading dimension of GIVNUM and POLES, must be at least N. !>
[out]	POLES	!> POLES is REAL array, dimension ( LDGNUM, 2 ) !> On exit, POLES(1,*) is an array containing the new singular !> values obtained from solving the secular equation, and !> POLES(2,*) is an array containing the poles in the secular !> equation. Not referenced if ICOMPQ = 0. !>
[out]	DIFL	!> DIFL is REAL array, dimension ( N ) !> On exit, DIFL(I) is the distance between I-th updated !> (undeflated) singular value and the I-th (undeflated) old !> singular value. !>
[out]	DIFR	!> DIFR is REAL array, !> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and !> dimension ( K ) if ICOMPQ = 0. !> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not !> defined and will not be referenced. !> !> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the !> normalizing factors for the right singular vector matrix. !> !> See SLASD8 for details on DIFL and DIFR. !>
[out]	Z	!> Z is REAL array, dimension ( M ) !> The first elements of this array contain the components !> of the deflation-adjusted updating row vector. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, !> This is the order of the related secular equation. 1 <= K <=N. !>
[out]	C	!> C is REAL !> C contains garbage if SQRE =0 and the C-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	S	!> S is REAL !> S contains garbage if SQRE =0 and the S-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	WORK	!> WORK is REAL array, dimension ( 4 * M ) !>
[out]	IWORK	!> IWORK is INTEGER array, dimension ( 3 * N ) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 309 of file slasd6.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
     $                   NR, SQRE
      REAL               ALPHA, BETA, C, S
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
     $                   PERM( * )
      REAL               D( * ), DIFL( * ), DIFR( * ),
     $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
     $                   VF( * ), VL( * ), WORK( * ), Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
     $                   N, N1, N2
      REAL               ORGNRM
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slamrg, slascl, slasd7, slasd8, xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      n = nl + nr + 1
      m = n + sqre
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( nl.LT.1 ) THEN
         info = -2
      ELSE IF( nr.LT.1 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldgcol.LT.n ) THEN
         info = -14
      ELSE IF( ldgnum.LT.n ) THEN
         info = -16
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD6', -info )
         RETURN
      END IF
*
*     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 SLASD7 and SLASD8.
*
      isigma = 1
      iw = isigma + n
      ivfw = iw + m
      ivlw = ivfw + m
*
      idx = 1
      idxc = idx + n
      idxp = idxc + n
*
*     Scale.
*
      orgnrm = max( abs( alpha ), abs( beta ) )
      d( nl+1 ) = zero
      DO 10 i = 1, n
         IF( abs( d( i ) ).GT.orgnrm ) THEN
            orgnrm = abs( d( i ) )
         END IF
   10 CONTINUE
      CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info )
      alpha = alpha / orgnrm
      beta = beta / orgnrm
*
*     Sort and Deflate singular values.
*
      CALL slasd7( icompq, nl, nr, sqre, k, d, z, work( iw ), vf,
     $             work( ivfw ), vl, work( ivlw ), alpha, beta,
     $             work( isigma ), iwork( idx ), iwork( idxp ), idxq,
     $             perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s,
     $             info )
*
*     Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
*
      CALL slasd8( icompq, k, d, z, vf, vl, difl, difr, ldgnum,
     $             work( isigma ), work( iw ), info )
*
*     Report the possible convergence failure.
*
      IF( info.NE.0 ) THEN
         RETURN
      END IF
*
*     Save the poles if ICOMPQ = 1.
*
      IF( icompq.EQ.1 ) THEN
         CALL scopy( k, d, 1, poles( 1, 1 ), 1 )
         CALL scopy( k, work( isigma ), 1, poles( 1, 2 ), 1 )
      END IF
*
*     Unscale.
*
      CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info )
*
*     Prepare the IDXQ sorting permutation.
*
      n1 = k
      n2 = n - k
      CALL slamrg( n1, n2, d, 1, -1, idxq )
*
      RETURN
*
*     End of SLASD6
*

slasd7()

subroutine slasd7	(	integer	icompq,
		integer	nl,
		integer	nr,
		integer	sqre,
		integer	k,
		real, dimension( * )	d,
		real, dimension( * )	z,
		real, dimension( * )	zw,
		real, dimension( * )	vf,
		real, dimension( * )	vfw,
		real, dimension( * )	vl,
		real, dimension( * )	vlw,
		real	alpha,
		real	beta,
		real, dimension( * )	dsigma,
		integer, dimension( * )	idx,
		integer, dimension( * )	idxp,
		integer, dimension( * )	idxq,
		integer, dimension( * )	perm,
		integer	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		real, dimension( ldgnum, * )	givnum,
		integer	ldgnum,
		real	c,
		real	s,
		integer	info )

SLASD7 merges the two sets of singular values together into a single sorted set. Then it tries to deflate the size of the problem. Used by sbdsdc.

Download SLASD7 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD7 merges the two sets of singular values 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 singular
!> values 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.
!>
!> SLASD7 is called from SLASD6.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed !> in compact form, as follows: !> = 0: Compute singular values only. !> = 1: Compute singular vectors of upper !> bidiagonal matrix in compact form. !>
[in]	NL	!> NL is INTEGER !> The row dimension of the upper block. NL >= 1. !>
[in]	NR	!> NR is INTEGER !> The row dimension of the lower block. NR >= 1. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: the lower block is an NR-by-NR square matrix. !> = 1: the lower block is an NR-by-(NR+1) rectangular matrix. !> !> The bidiagonal matrix has !> N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[out]	K	!> K is INTEGER !> Contains the dimension of the non-deflated matrix, this is !> the order of the related secular equation. 1 <= K <=N. !>
[in,out]	D	!> D is REAL array, dimension ( N ) !> On entry D contains the singular values of the two submatrices !> to be combined. On exit D contains the trailing (N-K) updated !> singular values (those which were deflated) sorted into !> increasing order. !>
[out]	Z	!> Z is REAL array, dimension ( M ) !> On exit Z contains the updating row vector in the secular !> equation. !>
[out]	ZW	!> ZW is REAL array, dimension ( M ) !> Workspace for Z. !>
[in,out]	VF	!> VF is REAL array, dimension ( M ) !> On entry, VF(1:NL+1) contains the first components of all !> right singular vectors of the upper block; and VF(NL+2:M) !> contains the first components of all right singular vectors !> of the lower block. On exit, VF contains the first components !> of all right singular vectors of the bidiagonal matrix. !>
[out]	VFW	!> VFW is REAL array, dimension ( M ) !> Workspace for VF. !>
[in,out]	VL	!> VL is REAL array, dimension ( M ) !> On entry, VL(1:NL+1) contains the last components of all !> right singular vectors of the upper block; and VL(NL+2:M) !> contains the last components of all right singular vectors !> of the lower block. On exit, VL contains the last components !> of all right singular vectors of the bidiagonal matrix. !>
[out]	VLW	!> VLW is REAL array, dimension ( M ) !> Workspace for VL. !>
[in]	ALPHA	!> ALPHA is REAL !> Contains the diagonal element associated with the added row. !>
[in]	BETA	!> BETA is REAL !> Contains the off-diagonal element associated with the added !> row. !>
[out]	DSIGMA	!> DSIGMA is REAL array, dimension ( N ) !> Contains a copy of the diagonal elements (K-1 singular values !> and one zero) in the secular equation. !>
[out]	IDX	!> IDX is INTEGER array, dimension ( N ) !> This will contain the permutation used to sort the contents of !> D into ascending order. !>
[out]	IDXP	!> IDXP is INTEGER array, dimension ( N ) !> This will contain the permutation used to place deflated !> values of D at the end of the array. On output IDXP(2:K) !> points to the nondeflated D-values and IDXP(K+1:N) !> points to the deflated singular values. !>
[in]	IDXQ	!> IDXQ is INTEGER array, dimension ( N ) !> This contains the permutation which separately sorts the two !> sub-problems in D into ascending order. Note that entries in !> the first half of this permutation must first be moved one !> position backward; and entries in the second half !> must first have NL+1 added to their values. !>
[out]	PERM	!> PERM is INTEGER array, dimension ( N ) !> The permutations (from deflation and sorting) to be applied !> to each singular block. Not referenced if ICOMPQ = 0. !>
[out]	GIVPTR	!> GIVPTR is INTEGER !> The number of Givens rotations which took place in this !> subproblem. Not referenced if ICOMPQ = 0. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) !> Each pair of numbers indicates a pair of columns to take place !> in a Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGCOL	!> LDGCOL is INTEGER !> The leading dimension of GIVCOL, must be at least N. !>
[out]	GIVNUM	!> GIVNUM is REAL array, dimension ( LDGNUM, 2 ) !> Each number indicates the C or S value to be used in the !> corresponding Givens rotation. Not referenced if ICOMPQ = 0. !>
[in]	LDGNUM	!> LDGNUM is INTEGER !> The leading dimension of GIVNUM, must be at least N. !>
[out]	C	!> C is REAL !> C contains garbage if SQRE =0 and the C-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	S	!> S is REAL !> S contains garbage if SQRE =0 and the S-value of a Givens !> rotation related to the right null space if SQRE = 1. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 276 of file slasd7.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
     $                   NR, SQRE
      REAL               ALPHA, BETA, C, S
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
     $                   IDXQ( * ), PERM( * )
      REAL               D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
     $                   VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
     $                   ZW( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, EIGHT
      parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
     $                   eight = 8.0e+0 )
*     ..
*     .. Local Scalars ..
*
      INTEGER            I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
     $                   NLP1, NLP2
      REAL               EPS, HLFTOL, TAU, TOL, Z1
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slamrg, srot, xerbla
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLAPY2
      EXTERNAL           slamch, slapy2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      n = nl + nr + 1
      m = n + sqre
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( nl.LT.1 ) THEN
         info = -2
      ELSE IF( nr.LT.1 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldgcol.LT.n ) THEN
         info = -22
      ELSE IF( ldgnum.LT.n ) THEN
         info = -24
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD7', -info )
         RETURN
      END IF
*
      nlp1 = nl + 1
      nlp2 = nl + 2
      IF( icompq.EQ.1 ) THEN
         givptr = 0
      END IF
*
*     Generate the first part of the vector Z and move the singular
*     values in the first part of D one position backward.
*
      z1 = alpha*vl( nlp1 )
      vl( nlp1 ) = zero
      tau = vf( nlp1 )
      DO 10 i = nl, 1, -1
         z( i+1 ) = alpha*vl( i )
         vl( i ) = zero
         vf( i+1 ) = vf( i )
         d( i+1 ) = d( i )
         idxq( i+1 ) = idxq( i ) + 1
   10 CONTINUE
      vf( 1 ) = tau
*
*     Generate the second part of the vector Z.
*
      DO 20 i = nlp2, m
         z( i ) = beta*vf( i )
         vf( i ) = zero
   20 CONTINUE
*
*     Sort the singular values into increasing order
*
      DO 30 i = nlp2, n
         idxq( i ) = idxq( i ) + nlp1
   30 CONTINUE
*
*     DSIGMA, IDXC, IDXC, and ZW are used as storage space.
*
      DO 40 i = 2, n
         dsigma( i ) = d( idxq( i ) )
         zw( i ) = z( idxq( i ) )
         vfw( i ) = vf( idxq( i ) )
         vlw( i ) = vl( idxq( i ) )
   40 CONTINUE
*
      CALL slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) )
*
      DO 50 i = 2, n
         idxi = 1 + idx( i )
         d( i ) = dsigma( idxi )
         z( i ) = zw( idxi )
         vf( i ) = vfw( idxi )
         vl( i ) = vlw( idxi )
   50 CONTINUE
*
*     Calculate the allowable deflation tolerance
*
      eps = slamch( 'Epsilon' )
      tol = max( abs( alpha ), abs( beta ) )
      tol = eight*eight*eps*max( abs( d( n ) ), tol )
*
*     There are 2 kinds of deflation -- first a value in the z-vector
*     is small, second two (or more) singular values are very close
*     together (their difference is small).
*
*     If the value in the z-vector is small, we simply permute the
*     array so that the corresponding singular value is moved to the
*     end.
*
*     If two values in the D-vector are close, we perform a two-sided
*     rotation designed to make one of the corresponding z-vector
*     entries zero, and then permute the array so that the deflated
*     singular value is moved to the end.
*
*     If there are multiple singular values then the problem deflates.
*     Here the number of equal singular values are found.  As each equal
*     singular value is found, an elementary reflector is computed to
*     rotate the corresponding singular subspace so that the
*     corresponding components of Z are zero in this new basis.
*
      k = 1
      k2 = n + 1
      DO 60 j = 2, n
         IF( abs( z( j ) ).LE.tol ) THEN
*
*           Deflate due to small z component.
*
            k2 = k2 - 1
            idxp( k2 ) = j
            IF( j.EQ.n )
     $         GO TO 100
         ELSE
            jprev = j
            GO TO 70
         END IF
   60 CONTINUE
   70 CONTINUE
      j = jprev
   80 CONTINUE
      j = j + 1
      IF( j.GT.n )
     $   GO TO 90
      IF( abs( z( j ) ).LE.tol ) THEN
*
*        Deflate due to small z component.
*
         k2 = k2 - 1
         idxp( k2 ) = j
      ELSE
*
*        Check if singular values are close enough to allow deflation.
*
         IF( abs( d( j )-d( jprev ) ).LE.tol ) THEN
*
*           Deflation is possible.
*
            s = z( jprev )
            c = z( j )
*
*           Find sqrt(a**2+b**2) without overflow or
*           destructive underflow.
*
            tau = slapy2( c, s )
            z( j ) = tau
            z( jprev ) = zero
            c = c / tau
            s = -s / tau
*
*           Record the appropriate Givens rotation
*
            IF( icompq.EQ.1 ) THEN
               givptr = givptr + 1
               idxjp = idxq( idx( jprev )+1 )
               idxj = idxq( idx( j )+1 )
               IF( idxjp.LE.nlp1 ) THEN
                  idxjp = idxjp - 1
               END IF
               IF( idxj.LE.nlp1 ) THEN
                  idxj = idxj - 1
               END IF
               givcol( givptr, 2 ) = idxjp
               givcol( givptr, 1 ) = idxj
               givnum( givptr, 2 ) = c
               givnum( givptr, 1 ) = s
            END IF
            CALL srot( 1, vf( jprev ), 1, vf( j ), 1, c, s )
            CALL srot( 1, vl( jprev ), 1, vl( j ), 1, c, s )
            k2 = k2 - 1
            idxp( k2 ) = jprev
            jprev = j
         ELSE
            k = k + 1
            zw( k ) = z( jprev )
            dsigma( k ) = d( jprev )
            idxp( k ) = jprev
            jprev = j
         END IF
      END IF
      GO TO 80
   90 CONTINUE
*
*     Record the last singular value.
*
      k = k + 1
      zw( k ) = z( jprev )
      dsigma( k ) = d( jprev )
      idxp( k ) = jprev
*
  100 CONTINUE
*
*     Sort the singular values into DSIGMA. The singular values which
*     were not deflated go into the first K slots of DSIGMA, except
*     that DSIGMA(1) is treated separately.
*
      DO 110 j = 2, n
         jp = idxp( j )
         dsigma( j ) = d( jp )
         vfw( j ) = vf( jp )
         vlw( j ) = vl( jp )
  110 CONTINUE
      IF( icompq.EQ.1 ) THEN
         DO 120 j = 2, n
            jp = idxp( j )
            perm( j ) = idxq( idx( jp )+1 )
            IF( perm( j ).LE.nlp1 ) THEN
               perm( j ) = perm( j ) - 1
            END IF
  120    CONTINUE
      END IF
*
*     The deflated singular values go back into the last N - K slots of
*     D.
*
      CALL scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 )
*
*     Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
*     VL(M).
*
      dsigma( 1 ) = zero
      hlftol = tol / two
      IF( abs( dsigma( 2 ) ).LE.hlftol )
     $   dsigma( 2 ) = hlftol
      IF( m.GT.n ) THEN
         z( 1 ) = slapy2( z1, z( m ) )
         IF( z( 1 ).LE.tol ) THEN
            c = one
            s = zero
            z( 1 ) = tol
         ELSE
            c = z1 / z( 1 )
            s = -z( m ) / z( 1 )
         END IF
         CALL srot( 1, vf( m ), 1, vf( 1 ), 1, c, s )
         CALL srot( 1, vl( m ), 1, vl( 1 ), 1, c, s )
      ELSE
         IF( abs( z1 ).LE.tol ) THEN
            z( 1 ) = tol
         ELSE
            z( 1 ) = z1
         END IF
      END IF
*
*     Restore Z, VF, and VL.
*
      CALL scopy( k-1, zw( 2 ), 1, z( 2 ), 1 )
      CALL scopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 )
      CALL scopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 )
*
      RETURN
*
*     End of SLASD7
*

slasd8()

subroutine slasd8	(	integer	icompq,
		integer	k,
		real, dimension( * )	d,
		real, dimension( * )	z,
		real, dimension( * )	vf,
		real, dimension( * )	vl,
		real, dimension( * )	difl,
		real, dimension( lddifr, * )	difr,
		integer	lddifr,
		real, dimension( * )	dsigma,
		real, dimension( * )	work,
		integer	info )

SLASD8 finds the square roots of the roots of the secular equation, and stores, for each element in D, the distance to its two nearest poles. Used by sbdsdc.

Download SLASD8 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASD8 finds the square roots of the roots of the secular equation,
!> as defined by the values in DSIGMA and Z. It makes the appropriate
!> calls to SLASD4, and stores, for each  element in D, the distance
!> to its two nearest poles (elements in DSIGMA). It also updates
!> the arrays VF and VL, the first and last components of all the
!> right singular vectors of the original bidiagonal matrix.
!>
!> SLASD8 is called from SLASD6.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed in !> factored form in the calling routine: !> = 0: Compute singular values only. !> = 1: Compute singular vectors in factored form as well. !>
[in]	K	!> K is INTEGER !> The number of terms in the rational function to be solved !> by SLASD4. K >= 1. !>
[out]	D	!> D is REAL array, dimension ( K ) !> On output, D contains the updated singular values. !>
[in,out]	Z	!> Z is REAL array, dimension ( K ) !> On entry, the first K elements of this array contain the !> components of the deflation-adjusted updating row vector. !> On exit, Z is updated. !>
[in,out]	VF	!> VF is REAL array, dimension ( K ) !> On entry, VF contains information passed through DBEDE8. !> On exit, VF contains the first K components of the first !> components of all right singular vectors of the bidiagonal !> matrix. !>
[in,out]	VL	!> VL is REAL array, dimension ( K ) !> On entry, VL contains information passed through DBEDE8. !> On exit, VL contains the first K components of the last !> components of all right singular vectors of the bidiagonal !> matrix. !>
[out]	DIFL	!> DIFL is REAL array, dimension ( K ) !> On exit, DIFL(I) = D(I) - DSIGMA(I). !>
[out]	DIFR	!> DIFR is REAL array, !> dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and !> dimension ( K ) if ICOMPQ = 0. !> On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not !> defined and will not be referenced. !> !> If ICOMPQ = 1, DIFR(1:K,2) is an array containing the !> normalizing factors for the right singular vector matrix. !>
[in]	LDDIFR	!> LDDIFR is INTEGER !> The leading dimension of DIFR, must be at least K. !>
[in,out]	DSIGMA	!> DSIGMA is REAL array, dimension ( K ) !> On entry, the first K elements of this array contain the old !> roots of the deflated updating problem. These are the poles !> of the secular equation. !> On exit, the elements of DSIGMA may be very slightly altered !> in value. !>
[out]	WORK	!> WORK is REAL array, dimension (3*K) !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 164 of file slasd8.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, K, LDDIFR
*     ..
*     .. Array Arguments ..
      REAL               D( * ), DIFL( * ), DIFR( LDDIFR, * ),
     $                   DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
     $                   Z( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      parameter( one = 1.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
      REAL               DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slascl, slasd4, slaset, xerbla
*     ..
*     .. External Functions ..
      REAL               SDOT, SLAMC3, SNRM2
      EXTERNAL           sdot, slamc3, snrm2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( k.LT.1 ) THEN
         info = -2
      ELSE IF( lddifr.LT.k ) THEN
         info = -9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASD8', -info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( k.EQ.1 ) THEN
         d( 1 ) = abs( z( 1 ) )
         difl( 1 ) = d( 1 )
         IF( icompq.EQ.1 ) THEN
            difl( 2 ) = one
            difr( 1, 2 ) = one
         END IF
         RETURN
      END IF
*
*     Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(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 DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
*     which on any of these machines zeros out the bottommost
*     bit of DSIGMA(I) if it is 1; this makes the subsequent
*     subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
*     occurs. On binary machines with a guard digit (almost all
*     machines) it does not change DSIGMA(I) at all. On hexadecimal
*     and decimal machines with a guard digit, it slightly
*     changes the bottommost bits of DSIGMA(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 10 i = 1, k
         dsigma( i ) = slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i )
   10 CONTINUE
*
*     Book keeping.
*
      iwk1 = 1
      iwk2 = iwk1 + k
      iwk3 = iwk2 + k
      iwk2i = iwk2 - 1
      iwk3i = iwk3 - 1
*
*     Normalize Z.
*
      rho = snrm2( k, z, 1 )
      CALL slascl( 'G', 0, 0, rho, one, k, 1, z, k, info )
      rho = rho*rho
*
*     Initialize WORK(IWK3).
*
      CALL slaset( 'A', k, 1, one, one, work( iwk3 ), k )
*
*     Compute the updated singular values, the arrays DIFL, DIFR,
*     and the updated Z.
*
      DO 40 j = 1, k
         CALL slasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ),
     $                work( iwk2 ), info )
*
*        If the root finder fails, report the convergence failure.
*
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         work( iwk3i+j ) = work( iwk3i+j )*work( j )*work( iwk2i+j )
         difl( j ) = -work( j )
         difr( j, 1 ) = -work( j+1 )
         DO 20 i = 1, j - 1
            work( iwk3i+i ) = work( iwk3i+i )*work( i )*
     $                        work( iwk2i+i ) / ( dsigma( i )-
     $                        dsigma( j ) ) / ( dsigma( i )+
     $                        dsigma( j ) )
   20    CONTINUE
         DO 30 i = j + 1, k
            work( iwk3i+i ) = work( iwk3i+i )*work( i )*
     $                        work( iwk2i+i ) / ( dsigma( i )-
     $                        dsigma( j ) ) / ( dsigma( i )+
     $                        dsigma( j ) )
   30    CONTINUE
   40 CONTINUE
*
*     Compute updated Z.
*
      DO 50 i = 1, k
         z( i ) = sign( sqrt( abs( work( iwk3i+i ) ) ), z( i ) )
   50 CONTINUE
*
*     Update VF and VL.
*
      DO 80 j = 1, k
         diflj = difl( j )
         dj = d( j )
         dsigj = -dsigma( j )
         IF( j.LT.k ) THEN
            difrj = -difr( j, 1 )
            dsigjp = -dsigma( j+1 )
         END IF
         work( j ) = -z( j ) / diflj / ( dsigma( j )+dj )
         DO 60 i = 1, j - 1
            work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigj )-diflj )
     $                   / ( dsigma( i )+dj )
   60    CONTINUE
         DO 70 i = j + 1, k
            work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigjp )+difrj )
     $                   / ( dsigma( i )+dj )
   70    CONTINUE
         temp = snrm2( k, work, 1 )
         work( iwk2i+j ) = sdot( k, work, 1, vf, 1 ) / temp
         work( iwk3i+j ) = sdot( k, work, 1, vl, 1 ) / temp
         IF( icompq.EQ.1 ) THEN
            difr( j, 2 ) = temp
         END IF
   80 CONTINUE
*
      CALL scopy( k, work( iwk2 ), 1, vf, 1 )
      CALL scopy( k, work( iwk3 ), 1, vl, 1 )
*
      RETURN
*
*     End of SLASD8
*

slasda()

subroutine slasda	(	integer	icompq,
		integer	smlsiz,
		integer	n,
		integer	sqre,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldu, * )	vt,
		integer, dimension( * )	k,
		real, dimension( ldu, * )	difl,
		real, dimension( ldu, * )	difr,
		real, dimension( ldu, * )	z,
		real, dimension( ldu, * )	poles,
		integer, dimension( * )	givptr,
		integer, dimension( ldgcol, * )	givcol,
		integer	ldgcol,
		integer, dimension( ldgcol, * )	perm,
		real, dimension( ldu, * )	givnum,
		real, dimension( * )	c,
		real, dimension( * )	s,
		real, dimension( * )	work,
		integer, dimension( * )	iwork,
		integer	info )

SLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.

Download SLASDA + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> Using a divide and conquer approach, SLASDA computes the singular
!> value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
!> B with diagonal D and offdiagonal E, where M = N + SQRE. The
!> algorithm computes the singular values in the SVD B = U * S * VT.
!> The orthogonal matrices U and VT are optionally computed in
!> compact form.
!>
!> A related subroutine, SLASD0, computes the singular values and
!> the singular vectors in explicit form.
!> 

Parameters

[in]	ICOMPQ	!> ICOMPQ is INTEGER !> Specifies whether singular vectors are to be computed !> in compact form, as follows !> = 0: Compute singular values only. !> = 1: Compute singular vectors of upper bidiagonal !> matrix in compact form. !>
[in]	SMLSIZ	!> SMLSIZ is INTEGER !> The maximum size of the subproblems at the bottom of the !> computation tree. !>
[in]	N	!> N is INTEGER !> The row dimension of the upper bidiagonal matrix. This is !> also the dimension of the main diagonal array D. !>
[in]	SQRE	!> SQRE is INTEGER !> Specifies the column dimension of the bidiagonal matrix. !> = 0: The bidiagonal matrix has column dimension M = N; !> = 1: The bidiagonal matrix has column dimension M = N + 1. !>
[in,out]	D	!> D is REAL array, dimension ( N ) !> On entry D contains the main diagonal of the bidiagonal !> matrix. On exit D, if INFO = 0, contains its singular values. !>
[in]	E	!> E is REAL array, dimension ( M-1 ) !> Contains the subdiagonal entries of the bidiagonal matrix. !> On exit, E has been destroyed. !>
[out]	U	!> U is REAL array, !> dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left !> singular vector matrices of all subproblems at the bottom !> level. !>
[in]	LDU	!> LDU is INTEGER, LDU = > N. !> The leading dimension of arrays U, VT, DIFL, DIFR, POLES, !> GIVNUM, and Z. !>
[out]	VT	!> VT is REAL array, !> dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right !> singular vector matrices of all subproblems at the bottom !> level. !>
[out]	K	!> K is INTEGER array, dimension ( N ) !> if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. !> If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th !> secular equation on the computation tree. !>
[out]	DIFL	!> DIFL is REAL array, dimension ( LDU, NLVL ), !> where NLVL = floor(log_2 (N/SMLSIZ))). !>
[out]	DIFR	!> DIFR is REAL array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and !> dimension ( N ) if ICOMPQ = 0. !> If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) !> record distances between singular values on the I-th !> level and singular values on the (I -1)-th level, and !> DIFR(1:N, 2 * I ) contains the normalizing factors for !> the right singular vector matrix. See SLASD8 for details. !>
[out]	Z	!> Z is REAL array, !> dimension ( LDU, NLVL ) if ICOMPQ = 1 and !> dimension ( N ) if ICOMPQ = 0. !> The first K elements of Z(1, I) contain the components of !> the deflation-adjusted updating row vector for subproblems !> on the I-th level. !>
[out]	POLES	!> POLES is REAL array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and !> POLES(1, 2*I) contain the new and old singular values !> involved in the secular equations on the I-th level. !>
[out]	GIVPTR	!> GIVPTR is INTEGER array, !> dimension ( N ) if ICOMPQ = 1, and not referenced if !> ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records !> the number of Givens rotations performed on the I-th !> problem on the computation tree. !>
[out]	GIVCOL	!> GIVCOL is INTEGER array, !> dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not !> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, !> GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations !> of Givens rotations performed on the I-th level on the !> computation tree. !>
[in]	LDGCOL	!> LDGCOL is INTEGER, LDGCOL = > N. !> The leading dimension of arrays GIVCOL and PERM. !>
[out]	PERM	!> PERM is INTEGER array, dimension ( LDGCOL, NLVL ) !> if ICOMPQ = 1, and not referenced !> if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records !> permutations done on the I-th level of the computation tree. !>
[out]	GIVNUM	!> GIVNUM is REAL array, !> dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not !> referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, !> GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- !> values of Givens rotations performed on the I-th level on !> the computation tree. !>
[out]	C	!> C is REAL array, !> dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. !> If ICOMPQ = 1 and the I-th subproblem is not square, on exit, !> C( I ) contains the C-value of a Givens rotation related to !> the right null space of the I-th subproblem. !>
[out]	S	!> S is REAL array, dimension ( N ) if !> ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 !> and the I-th subproblem is not square, on exit, S( I ) !> contains the S-value of a Givens rotation related to !> the right null space of the I-th subproblem. !>
[out]	WORK	!> WORK is REAL array, dimension !> (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (7*N). !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !> > 0: if INFO = 1, a singular value did not converge !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 270 of file slasda.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
     $                   K( * ), PERM( LDGCOL, * )
      REAL               C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
     $                   E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
     $                   S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
     $                   Z( LDU, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e+0, one = 1.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
     $                   J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
     $                   NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
     $                   NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
      REAL               ALPHA, BETA
*     ..
*     .. External Subroutines ..
      EXTERNAL           scopy, slasd6, slasdq, slasdt, slaset, xerbla
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
*
      IF( ( icompq.LT.0 ) .OR. ( icompq.GT.1 ) ) THEN
         info = -1
      ELSE IF( smlsiz.LT.3 ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -4
      ELSE IF( ldu.LT.( n+sqre ) ) THEN
         info = -8
      ELSE IF( ldgcol.LT.n ) THEN
         info = -17
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASDA', -info )
         RETURN
      END IF
*
      m = n + sqre
*
*     If the input matrix is too small, call SLASDQ to find the SVD.
*
      IF( n.LE.smlsiz ) THEN
         IF( icompq.EQ.0 ) THEN
            CALL slasdq( 'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu,
     $                   u, ldu, work, info )
         ELSE
            CALL slasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu,
     $                   u, ldu, work, info )
         END IF
         RETURN
      END IF
*
*     Book-keeping and  set up the computation tree.
*
      inode = 1
      ndiml = inode + n
      ndimr = ndiml + n
      idxq = ndimr + n
      iwk = idxq + n
*
      ncc = 0
      nru = 0
*
      smlszp = smlsiz + 1
      vf = 1
      vl = vf + m
      nwork1 = vl + m
      nwork2 = nwork1 + smlszp*smlszp
*
      CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),
     $             iwork( ndimr ), smlsiz )
*
*     for the nodes on bottom level of the tree, solve
*     their subproblems by SLASDQ.
*
      ndb1 = ( nd+1 ) / 2
      DO 30 i = ndb1, nd
*
*        IC : center row of each node
*        NL : number of rows of left  subproblem
*        NR : number of rows of right subproblem
*        NLF: starting row of the left   subproblem
*        NRF: starting row of the right  subproblem
*
         i1 = i - 1
         ic = iwork( inode+i1 )
         nl = iwork( ndiml+i1 )
         nlp1 = nl + 1
         nr = iwork( ndimr+i1 )
         nlf = ic - nl
         nrf = ic + 1
         idxqi = idxq + nlf - 2
         vfi = vf + nlf - 1
         vli = vl + nlf - 1
         sqrei = 1
         IF( icompq.EQ.0 ) THEN
            CALL slaset( 'A', nlp1, nlp1, zero, one, work( nwork1 ),
     $                   smlszp )
            CALL slasdq( 'U', sqrei, nl, nlp1, nru, ncc, d( nlf ),
     $                   e( nlf ), work( nwork1 ), smlszp,
     $                   work( nwork2 ), nl, work( nwork2 ), nl,
     $                   work( nwork2 ), info )
            itemp = nwork1 + nl*smlszp
            CALL scopy( nlp1, work( nwork1 ), 1, work( vfi ), 1 )
            CALL scopy( nlp1, work( itemp ), 1, work( vli ), 1 )
         ELSE
            CALL slaset( 'A', nl, nl, zero, one, u( nlf, 1 ), ldu )
            CALL slaset( 'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu )
            CALL slasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ),
     $                   e( nlf ), vt( nlf, 1 ), ldu, u( nlf, 1 ), ldu,
     $                   u( nlf, 1 ), ldu, work( nwork1 ), info )
            CALL scopy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 )
            CALL scopy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 )
         END IF
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         DO 10 j = 1, nl
            iwork( idxqi+j ) = j
   10    CONTINUE
         IF( ( i.EQ.nd ) .AND. ( sqre.EQ.0 ) ) THEN
            sqrei = 0
         ELSE
            sqrei = 1
         END IF
         idxqi = idxqi + nlp1
         vfi = vfi + nlp1
         vli = vli + nlp1
         nrp1 = nr + sqrei
         IF( icompq.EQ.0 ) THEN
            CALL slaset( 'A', nrp1, nrp1, zero, one, work( nwork1 ),
     $                   smlszp )
            CALL slasdq( 'U', sqrei, nr, nrp1, nru, ncc, d( nrf ),
     $                   e( nrf ), work( nwork1 ), smlszp,
     $                   work( nwork2 ), nr, work( nwork2 ), nr,
     $                   work( nwork2 ), info )
            itemp = nwork1 + ( nrp1-1 )*smlszp
            CALL scopy( nrp1, work( nwork1 ), 1, work( vfi ), 1 )
            CALL scopy( nrp1, work( itemp ), 1, work( vli ), 1 )
         ELSE
            CALL slaset( 'A', nr, nr, zero, one, u( nrf, 1 ), ldu )
            CALL slaset( 'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu )
            CALL slasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ),
     $                   e( nrf ), vt( nrf, 1 ), ldu, u( nrf, 1 ), ldu,
     $                   u( nrf, 1 ), ldu, work( nwork1 ), info )
            CALL scopy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 )
            CALL scopy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 )
         END IF
         IF( info.NE.0 ) THEN
            RETURN
         END IF
         DO 20 j = 1, nr
            iwork( idxqi+j ) = j
   20    CONTINUE
   30 CONTINUE
*
*     Now conquer each subproblem bottom-up.
*
      j = 2**nlvl
      DO 50 lvl = nlvl, 1, -1
         lvl2 = lvl*2 - 1
*
*        Find the first node LF and last node LL on
*        the current level LVL.
*
         IF( lvl.EQ.1 ) THEN
            lf = 1
            ll = 1
         ELSE
            lf = 2**( lvl-1 )
            ll = 2*lf - 1
         END IF
         DO 40 i = lf, ll
            im1 = i - 1
            ic = iwork( inode+im1 )
            nl = iwork( ndiml+im1 )
            nr = iwork( ndimr+im1 )
            nlf = ic - nl
            nrf = ic + 1
            IF( i.EQ.ll ) THEN
               sqrei = sqre
            ELSE
               sqrei = 1
            END IF
            vfi = vf + nlf - 1
            vli = vl + nlf - 1
            idxqi = idxq + nlf - 1
            alpha = d( ic )
            beta = e( ic )
            IF( icompq.EQ.0 ) THEN
               CALL slasd6( icompq, nl, nr, sqrei, d( nlf ),
     $                      work( vfi ), work( vli ), alpha, beta,
     $                      iwork( idxqi ), perm, givptr( 1 ), givcol,
     $                      ldgcol, givnum, ldu, poles, difl, difr, z,
     $                      k( 1 ), c( 1 ), s( 1 ), work( nwork1 ),
     $                      iwork( iwk ), info )
            ELSE
               j = j - 1
               CALL slasd6( icompq, nl, nr, sqrei, d( nlf ),
     $                      work( vfi ), work( vli ), alpha, beta,
     $                      iwork( idxqi ), perm( nlf, lvl ),
     $                      givptr( j ), givcol( nlf, lvl2 ), ldgcol,
     $                      givnum( nlf, lvl2 ), ldu,
     $                      poles( nlf, lvl2 ), difl( nlf, lvl ),
     $                      difr( nlf, lvl2 ), z( nlf, lvl ), k( j ),
     $                      c( j ), s( j ), work( nwork1 ),
     $                      iwork( iwk ), info )
            END IF
            IF( info.NE.0 ) THEN
               RETURN
            END IF
   40    CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of SLASDA
*

slasdq()

subroutine slasdq	(	character	uplo,
		integer	sqre,
		integer	n,
		integer	ncvt,
		integer	nru,
		integer	ncc,
		real, dimension( * )	d,
		real, dimension( * )	e,
		real, dimension( ldvt, * )	vt,
		integer	ldvt,
		real, dimension( ldu, * )	u,
		integer	ldu,
		real, dimension( ldc, * )	c,
		integer	ldc,
		real, dimension( * )	work,
		integer	info )

SLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.

Download SLASDQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASDQ computes the singular value decomposition (SVD) of a real
!> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
!> E, accumulating the transformations if desired. Letting B denote
!> the input bidiagonal matrix, the algorithm computes orthogonal
!> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose
!> of P). The singular values S are overwritten on D.
!>
!> The input matrix U  is changed to U  * Q  if desired.
!> The input matrix VT is changed to P**T * VT if desired.
!> The input matrix C  is changed to Q**T * C  if desired.
!>
!> See  by J. Demmel and W. Kahan,
!> LAPACK Working Note #3, for a detailed description of the algorithm.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> On entry, UPLO specifies whether the input bidiagonal matrix !> is upper or lower bidiagonal, and whether it is square are !> not. !> UPLO = 'U' or 'u' B is upper bidiagonal. !> UPLO = 'L' or 'l' B is lower bidiagonal. !>
[in]	SQRE	!> SQRE is INTEGER !> = 0: then the input matrix is N-by-N. !> = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and !> (N+1)-by-N if UPLU = 'L'. !> !> The bidiagonal matrix has !> N = NL + NR + 1 rows and !> M = N + SQRE >= N columns. !>
[in]	N	!> N is INTEGER !> On entry, N specifies the number of rows and columns !> in the matrix. N must be at least 0. !>
[in]	NCVT	!> NCVT is INTEGER !> On entry, NCVT specifies the number of columns of !> the matrix VT. NCVT must be at least 0. !>
[in]	NRU	!> NRU is INTEGER !> On entry, NRU specifies the number of rows of !> the matrix U. NRU must be at least 0. !>
[in]	NCC	!> NCC is INTEGER !> On entry, NCC specifies the number of columns of !> the matrix C. NCC must be at least 0. !>
[in,out]	D	!> D is REAL array, dimension (N) !> On entry, D contains the diagonal entries of the !> bidiagonal matrix whose SVD is desired. On normal exit, !> D contains the singular values in ascending order. !>
[in,out]	E	!> E is REAL array. !> dimension is (N-1) if SQRE = 0 and N if SQRE = 1. !> On entry, the entries of E contain the offdiagonal entries !> of the bidiagonal matrix whose SVD is desired. On normal !> exit, E will contain 0. If the algorithm does not converge, !> D and E will contain the diagonal and superdiagonal entries !> of a bidiagonal matrix orthogonally equivalent to the one !> given as input. !>
[in,out]	VT	!> VT is REAL array, dimension (LDVT, NCVT) !> On entry, contains a matrix which on exit has been !> premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 !> and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). !>
[in]	LDVT	!> LDVT is INTEGER !> On entry, LDVT specifies the leading dimension of VT as !> declared in the calling (sub) program. LDVT must be at !> least 1. If NCVT is nonzero LDVT must also be at least N. !>
[in,out]	U	!> U is REAL array, dimension (LDU, N) !> On entry, contains a matrix which on exit has been !> postmultiplied by Q, dimension NRU-by-N if SQRE = 0 !> and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). !>
[in]	LDU	!> LDU is INTEGER !> On entry, LDU specifies the leading dimension of U as !> declared in the calling (sub) program. LDU must be at !> least max( 1, NRU ) . !>
[in,out]	C	!> C is REAL array, dimension (LDC, NCC) !> On entry, contains an N-by-NCC matrix which on exit !> has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 !> and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). !>
[in]	LDC	!> LDC is INTEGER !> On entry, LDC specifies the leading dimension of C as !> declared in the calling (sub) program. LDC must be at !> least 1. If NCC is nonzero, LDC must also be at least N. !>
[out]	WORK	!> WORK is REAL array, dimension (4*N) !> Workspace. Only referenced if one of NCVT, NRU, or NCC is !> nonzero, and if N is at least 2. !>
[out]	INFO	!> INFO is INTEGER !> On exit, a value of 0 indicates a successful exit. !> If INFO < 0, argument number -INFO is illegal. !> If INFO > 0, the algorithm did not converge, and INFO !> specifies how many superdiagonals did not converge. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 209 of file slasdq.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
*     ..
*     .. Array Arguments ..
      REAL               C( LDC, * ), D( * ), E( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ROTATE
      INTEGER            I, ISUB, IUPLO, J, NP1, SQRE1
      REAL               CS, R, SMIN, SN
*     ..
*     .. External Subroutines ..
      EXTERNAL           sbdsqr, slartg, slasr, sswap, xerbla
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      info = 0
      iuplo = 0
      IF( lsame( uplo, 'U' ) )
     $   iuplo = 1
      IF( lsame( uplo, 'L' ) )
     $   iuplo = 2
      IF( iuplo.EQ.0 ) THEN
         info = -1
      ELSE IF( ( sqre.LT.0 ) .OR. ( sqre.GT.1 ) ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -3
      ELSE IF( ncvt.LT.0 ) THEN
         info = -4
      ELSE IF( nru.LT.0 ) THEN
         info = -5
      ELSE IF( ncc.LT.0 ) THEN
         info = -6
      ELSE IF( ( ncvt.EQ.0 .AND. ldvt.LT.1 ) .OR.
     $         ( ncvt.GT.0 .AND. ldvt.LT.max( 1, n ) ) ) THEN
         info = -10
      ELSE IF( ldu.LT.max( 1, nru ) ) THEN
         info = -12
      ELSE IF( ( ncc.EQ.0 .AND. ldc.LT.1 ) .OR.
     $         ( ncc.GT.0 .AND. ldc.LT.max( 1, n ) ) ) THEN
         info = -14
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASDQ', -info )
         RETURN
      END IF
      IF( n.EQ.0 )
     $   RETURN
*
*     ROTATE is true if any singular vectors desired, false otherwise
*
      rotate = ( ncvt.GT.0 ) .OR. ( nru.GT.0 ) .OR. ( ncc.GT.0 )
      np1 = n + 1
      sqre1 = sqre
*
*     If matrix non-square upper bidiagonal, rotate to be lower
*     bidiagonal.  The rotations are on the right.
*
      IF( ( iuplo.EQ.1 ) .AND. ( sqre1.EQ.1 ) ) THEN
         DO 10 i = 1, n - 1
            CALL slartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   10    CONTINUE
         CALL slartg( d( n ), e( n ), cs, sn, r )
         d( n ) = r
         e( n ) = zero
         IF( rotate ) THEN
            work( n ) = cs
            work( n+n ) = sn
         END IF
         iuplo = 2
         sqre1 = 0
*
*        Update singular vectors if desired.
*
         IF( ncvt.GT.0 )
     $      CALL slasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),
     $                  work( np1 ), vt, ldvt )
      END IF
*
*     If matrix lower bidiagonal, rotate to be upper bidiagonal
*     by applying Givens rotations on the left.
*
      IF( iuplo.EQ.2 ) THEN
         DO 20 i = 1, n - 1
            CALL slartg( d( i ), e( i ), cs, sn, r )
            d( i ) = r
            e( i ) = sn*d( i+1 )
            d( i+1 ) = cs*d( i+1 )
            IF( rotate ) THEN
               work( i ) = cs
               work( n+i ) = sn
            END IF
   20    CONTINUE
*
*        If matrix (N+1)-by-N lower bidiagonal, one additional
*        rotation is needed.
*
         IF( sqre1.EQ.1 ) THEN
            CALL slartg( d( n ), e( n ), cs, sn, r )
            d( n ) = r
            IF( rotate ) THEN
               work( n ) = cs
               work( n+n ) = sn
            END IF
         END IF
*
*        Update singular vectors if desired.
*
         IF( nru.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL slasr( 'R', 'V', 'F', nru, n, work( 1 ),
     $                     work( np1 ), u, ldu )
            ELSE
               CALL slasr( 'R', 'V', 'F', nru, np1, work( 1 ),
     $                     work( np1 ), u, ldu )
            END IF
         END IF
         IF( ncc.GT.0 ) THEN
            IF( sqre1.EQ.0 ) THEN
               CALL slasr( 'L', 'V', 'F', n, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            ELSE
               CALL slasr( 'L', 'V', 'F', np1, ncc, work( 1 ),
     $                     work( np1 ), c, ldc )
            END IF
         END IF
      END IF
*
*     Call SBDSQR to compute the SVD of the reduced real
*     N-by-N upper bidiagonal matrix.
*
      CALL sbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,
     $             ldc, work, info )
*
*     Sort the singular values into ascending order (insertion sort on
*     singular values, but only one transposition per singular vector)
*
      DO 40 i = 1, n
*
*        Scan for smallest D(I).
*
         isub = i
         smin = d( i )
         DO 30 j = i + 1, n
            IF( d( j ).LT.smin ) THEN
               isub = j
               smin = d( j )
            END IF
   30    CONTINUE
         IF( isub.NE.i ) THEN
*
*           Swap singular values and vectors.
*
            d( isub ) = d( i )
            d( i ) = smin
            IF( ncvt.GT.0 )
     $         CALL sswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt )
            IF( nru.GT.0 )
     $         CALL sswap( nru, u( 1, isub ), 1, u( 1, i ), 1 )
            IF( ncc.GT.0 )
     $         CALL sswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc )
         END IF
   40 CONTINUE
*
      RETURN
*
*     End of SLASDQ
*

slasdt()

subroutine slasdt	(	integer	n,
		integer	lvl,
		integer	nd,
		integer, dimension( * )	inode,
		integer, dimension( * )	ndiml,
		integer, dimension( * )	ndimr,
		integer	msub )

SLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc.

Download SLASDT + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASDT creates a tree of subproblems for bidiagonal divide and
!> conquer.
!> 

Parameters

[in]	N	!> N is INTEGER !> On entry, the number of diagonal elements of the !> bidiagonal matrix. !>
[out]	LVL	!> LVL is INTEGER !> On exit, the number of levels on the computation tree. !>
[out]	ND	!> ND is INTEGER !> On exit, the number of nodes on the tree. !>
[out]	INODE	!> INODE is INTEGER array, dimension ( N ) !> On exit, centers of subproblems. !>
[out]	NDIML	!> NDIML is INTEGER array, dimension ( N ) !> On exit, row dimensions of left children. !>
[out]	NDIMR	!> NDIMR is INTEGER array, dimension ( N ) !> On exit, row dimensions of right children. !>
[in]	MSUB	!> MSUB is INTEGER !> On entry, the maximum row dimension each subproblem at the !> bottom of the tree can be of. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Contributors:

Ming Gu and Huan Ren, Computer Science Division, University of California at Berkeley, USA

Definition at line 104 of file slasdt.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            LVL, MSUB, N, ND
*     ..
*     .. Array Arguments ..
      INTEGER            INODE( * ), NDIML( * ), NDIMR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               TWO
      parameter( two = 2.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IL, IR, LLST, MAXN, NCRNT, NLVL
      REAL               TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          int, log, max, real
*     ..
*     .. Executable Statements ..
*
*     Find the number of levels on the tree.
*
      maxn = max( 1, n )
      temp = log( real( maxn ) / real( msub+1 ) ) / log( two )
      lvl = int( temp ) + 1
*
      i = n / 2
      inode( 1 ) = i + 1
      ndiml( 1 ) = i
      ndimr( 1 ) = n - i - 1
      il = 0
      ir = 1
      llst = 1
      DO 20 nlvl = 1, lvl - 1
*
*        Constructing the tree at (NLVL+1)-st level. The number of
*        nodes created on this level is LLST * 2.
*
         DO 10 i = 0, llst - 1
            il = il + 2
            ir = ir + 2
            ncrnt = llst + i
            ndiml( il ) = ndiml( ncrnt ) / 2
            ndimr( il ) = ndiml( ncrnt ) - ndiml( il ) - 1
            inode( il ) = inode( ncrnt ) - ndimr( il ) - 1
            ndiml( ir ) = ndimr( ncrnt ) / 2
            ndimr( ir ) = ndimr( ncrnt ) - ndiml( ir ) - 1
            inode( ir ) = inode( ncrnt ) + ndiml( ir ) + 1
   10    CONTINUE
         llst = llst*2
   20 CONTINUE
      nd = llst*2 - 1
*
      RETURN
*
*     End of SLASDT
*

slaset()

subroutine slaset	(	character	uplo,
		integer	m,
		integer	n,
		real	alpha,
		real	beta,
		real, dimension( lda, * )	a,
		integer	lda )

SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.

Download SLASET + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASET initializes an m-by-n matrix A to BETA on the diagonal and
!> ALPHA on the offdiagonals.
!> 

Parameters

[in]	UPLO	!> UPLO is CHARACTER*1 !> Specifies the part of the matrix A to be set. !> = 'U': Upper triangular part is set; the strictly lower !> triangular part of A is not changed. !> = 'L': Lower triangular part is set; the strictly upper !> triangular part of A is not changed. !> Otherwise: All of the matrix A is set. !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in]	ALPHA	!> ALPHA is REAL !> The constant to which the offdiagonal elements are to be set. !>
[in]	BETA	!> BETA is REAL !> The constant to which the diagonal elements are to be set. !>
[out]	A	!> A is REAL array, dimension (LDA,N) !> On exit, the leading m-by-n submatrix of A is set as follows: !> !> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, !> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, !> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, !> !> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 109 of file slaset.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, M, N
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * )
*     ..
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          min
*     ..
*     .. Executable Statements ..
*
      IF( lsame( uplo, 'U' ) ) THEN
*
*        Set the strictly upper triangular or trapezoidal part of the
*        array to ALPHA.
*
         DO 20 j = 2, n
            DO 10 i = 1, min( j-1, m )
               a( i, j ) = alpha
   10       CONTINUE
   20    CONTINUE
*
      ELSE IF( lsame( uplo, 'L' ) ) THEN
*
*        Set the strictly lower triangular or trapezoidal part of the
*        array to ALPHA.
*
         DO 40 j = 1, min( m, n )
            DO 30 i = j + 1, m
               a( i, j ) = alpha
   30       CONTINUE
   40    CONTINUE
*
      ELSE
*
*        Set the leading m-by-n submatrix to ALPHA.
*
         DO 60 j = 1, n
            DO 50 i = 1, m
               a( i, j ) = alpha
   50       CONTINUE
   60    CONTINUE
      END IF
*
*     Set the first min(M,N) diagonal elements to BETA.
*
      DO 70 i = 1, min( m, n )
         a( i, i ) = beta
   70 CONTINUE
*
      RETURN
*
*     End of SLASET
*

slasr()

subroutine slasr	(	character	side,
		character	pivot,
		character	direct,
		integer	m,
		integer	n,
		real, dimension( * )	c,
		real, dimension( * )	s,
		real, dimension( lda, * )	a,
		integer	lda )

SLASR applies a sequence of plane rotations to a general rectangular matrix.

Download SLASR + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASR applies a sequence of plane rotations to a real matrix A,
!> from either the left or the right.
!>
!> When SIDE = 'L', the transformation takes the form
!>
!>    A := P*A
!>
!> and when SIDE = 'R', the transformation takes the form
!>
!>    A := A*P**T
!>
!> where P is an orthogonal matrix consisting of a sequence of z plane
!> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
!> and P**T is the transpose of P.
!>
!> When DIRECT = 'F' (Forward sequence), then
!>
!>    P = P(z-1) * ... * P(2) * P(1)
!>
!> and when DIRECT = 'B' (Backward sequence), then
!>
!>    P = P(1) * P(2) * ... * P(z-1)
!>
!> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
!>
!>    R(k) = (  c(k)  s(k) )
!>         = ( -s(k)  c(k) ).
!>
!> When PIVOT = 'V' (Variable pivot), the rotation is performed
!> for the plane (k,k+1), i.e., P(k) has the form
!>
!>    P(k) = (  1                                            )
!>           (       ...                                     )
!>           (              1                                )
!>           (                   c(k)  s(k)                  )
!>           (                  -s(k)  c(k)                  )
!>           (                                1              )
!>           (                                     ...       )
!>           (                                            1  )
!>
!> where R(k) appears as a rank-2 modification to the identity matrix in
!> rows and columns k and k+1.
!>
!> When PIVOT = 'T' (Top pivot), the rotation is performed for the
!> plane (1,k+1), so P(k) has the form
!>
!>    P(k) = (  c(k)                    s(k)                 )
!>           (         1                                     )
!>           (              ...                              )
!>           (                     1                         )
!>           ( -s(k)                    c(k)                 )
!>           (                                 1             )
!>           (                                      ...      )
!>           (                                             1 )
!>
!> where R(k) appears in rows and columns 1 and k+1.
!>
!> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
!> performed for the plane (k,z), giving P(k) the form
!>
!>    P(k) = ( 1                                             )
!>           (      ...                                      )
!>           (             1                                 )
!>           (                  c(k)                    s(k) )
!>           (                         1                     )
!>           (                              ...              )
!>           (                                     1         )
!>           (                 -s(k)                    c(k) )
!>
!> where R(k) appears in rows and columns k and z.  The rotations are
!> performed without ever forming P(k) explicitly.
!> 

Parameters

[in]	SIDE	!> SIDE is CHARACTER*1 !> Specifies whether the plane rotation matrix P is applied to !> A on the left or the right. !> = 'L': Left, compute A := P*A !> = 'R': Right, compute A:= A*P**T !>
[in]	PIVOT	!> PIVOT is CHARACTER*1 !> Specifies the plane for which P(k) is a plane rotation !> matrix. !> = 'V': Variable pivot, the plane (k,k+1) !> = 'T': Top pivot, the plane (1,k+1) !> = 'B': Bottom pivot, the plane (k,z) !>
[in]	DIRECT	!> DIRECT is CHARACTER*1 !> Specifies whether P is a forward or backward sequence of !> plane rotations. !> = 'F': Forward, P = P(z-1)*...*P(2)*P(1) !> = 'B': Backward, P = P(1)*P(2)*...*P(z-1) !>
[in]	M	!> M is INTEGER !> The number of rows of the matrix A. If m <= 1, an immediate !> return is effected. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. If n <= 1, an !> immediate return is effected. !>
[in]	C	!> C is REAL array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The cosines c(k) of the plane rotations. !>
[in]	S	!> S is REAL array, dimension !> (M-1) if SIDE = 'L' !> (N-1) if SIDE = 'R' !> The sines s(k) of the plane rotations. The 2-by-2 plane !> rotation part of the matrix P(k), R(k), has the form !> R(k) = ( c(k) s(k) ) !> ( -s(k) c(k) ). !>
[in,out]	A	!> A is REAL array, dimension (LDA,N) !> The M-by-N matrix A. On exit, A is overwritten by P*A if !> SIDE = 'R' or by A*P**T if SIDE = 'L'. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 198 of file slasr.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), C( * ), S( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
      REAL               CTEMP, STEMP, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      info = 0
      IF( .NOT.( lsame( side, 'L' ) .OR. lsame( side, 'R' ) ) ) THEN
         info = 1
      ELSE IF( .NOT.( lsame( pivot, 'V' ) .OR. lsame( pivot,
     $         'T' ) .OR. lsame( pivot, 'B' ) ) ) THEN
         info = 2
      ELSE IF( .NOT.( lsame( direct, 'F' ) .OR. lsame( direct, 'B' ) ) )
     $          THEN
         info = 3
      ELSE IF( m.LT.0 ) THEN
         info = 4
      ELSE IF( n.LT.0 ) THEN
         info = 5
      ELSE IF( lda.LT.max( 1, m ) ) THEN
         info = 9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SLASR ', info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
     $   RETURN
      IF( lsame( side, 'L' ) ) THEN
*
*        Form  P * A
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 20 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 10 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 40 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 30 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 60 j = 2, m
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 50 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 80 j = m, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 70 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 100 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 90 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 120 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 110 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( lsame( side, 'R' ) ) THEN
*
*        Form A * P**T
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 140 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 130 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 160 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 150 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 180 j = 2, n
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 170 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 200 j = n, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 190 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 220 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 210 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 240 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 230 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of SLASR
*

slassq()

subroutine slassq	(	integer	n,
		real(wp), dimension(*)	x,
		integer	incx,
		real(wp)	scl,
		real(wp)	sumsq )

SLASSQ updates a sum of squares represented in scaled form.

Download SLASSQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASSQ  returns the values  scl  and  smsq  such that
!>
!>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!>
!> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!>    we require:   scale >= sqrt( TINY*EPS ) / sbig   on entry,
!> and if 0 < scale * sqrt( sumsq ) < tsml then
!>    we require:   scale <= sqrt( HUGE ) / ssml       on entry,
!> where
!>    tbig -- upper threshold for values whose square is representable;
!>    sbig -- scaling constant for big numbers; \see la_constants.f90
!>    tsml -- lower threshold for values whose square is representable;
!>    ssml -- scaling constant for small numbers; \see la_constants.f90
!> and
!>    TINY*EPS -- tiniest representable number;
!>    HUGE     -- biggest representable number.
!>
!> 

Parameters

[in]	N	!> N is INTEGER !> The number of elements to be used from the vector x. !>
[in]	X	!> X is REAL array, dimension (1+(N-1)*abs(INCX)) !> The vector for which a scaled sum of squares is computed. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !>
[in]	INCX	!> INCX is INTEGER !> The increment between successive values of the vector x. !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX = 0, x isn't a vector so there is no need to call !> this subroutine. If you call it anyway, it will count x(1) !> in the vector norm N times. !>
[in,out]	SCALE	!> SCALE is REAL !> On entry, the value scale in the equation above. !> On exit, SCALE is overwritten with scl , the scaling factor !> for the sum of squares. !>
[in,out]	SUMSQ	!> SUMSQ is REAL !> On entry, the value sumsq in the equation above. !> On exit, SUMSQ is overwritten with smsq , the basic sum of !> squares from which scl has been factored out. !>

Author

Edward Anderson, Lockheed Martin

Contributors:

Weslley Pereira, University of Colorado Denver, USA Nick Papior, Technical University of Denmark, DK

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> 

Definition at line 136 of file slassq.f90.

   use la_constants, &
      only: wp=>sp, zero=>szero, one=>sone, &
            sbig=>ssbig, ssml=>sssml, tbig=>stbig, tsml=>stsml
   use la_xisnan
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Scalar Arguments ..
   integer :: incx, n
   real(wp) :: scl, sumsq
!  ..
!  .. Array Arguments ..
   real(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, ymax, ymin
!  ..
!
!  Quick return if possible
!
   if( la_isnan(scl) .or. la_isnan(sumsq) ) return
   if( sumsq == zero ) scl = one
   if( scl == zero ) then
      scl = one
      sumsq = zero
   end if
   if (n <= 0) then
      return
   end if
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(x(ix))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Put the existing sum of squares into one of the accumulators
!
   if( sumsq > zero ) then
      ax = scl*sqrt( sumsq )
      if (ax > tbig) then
!        We assume scl >= sqrt( TINY*EPS ) / sbig
         abig = abig + (scl*sbig)**2 * sumsq
      else if (ax < tsml) then
!        We assume scl <= sqrt( HUGE ) / ssml
         if (notbig) asml = asml + (scl*ssml)**2 * sumsq
      else
         amed = amed + scl**2 * sumsq
      end if
   end if
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range or zero
!
      scl = one
      sumsq = amed
   end if
   return

slasv2()

subroutine slasv2	(	real	f,
		real	g,
		real	h,
		real	ssmin,
		real	ssmax,
		real	snr,
		real	csr,
		real	snl,
		real	csl )

SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.

Download SLASV2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> SLASV2 computes the singular value decomposition of a 2-by-2
!> triangular matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
!> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
!> right singular vectors for abs(SSMAX), giving the decomposition
!>
!>    [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
!>    [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
!> 

Parameters

[in]	F	!> F is REAL !> The (1,1) element of the 2-by-2 matrix. !>
[in]	G	!> G is REAL !> The (1,2) element of the 2-by-2 matrix. !>
[in]	H	!> H is REAL !> The (2,2) element of the 2-by-2 matrix. !>
[out]	SSMIN	!> SSMIN is REAL !> abs(SSMIN) is the smaller singular value. !>
[out]	SSMAX	!> SSMAX is REAL !> abs(SSMAX) is the larger singular value. !>
[out]	SNL	!> SNL is REAL !>
[out]	CSL	!> CSL is REAL !> The vector (CSL, SNL) is a unit left singular vector for the !> singular value abs(SSMAX). !>
[out]	SNR	!> SNR is REAL !>
[out]	CSR	!> CSR is REAL !> The vector (CSR, SNR) is a unit right singular vector for the !> singular value abs(SSMAX). !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  Any input parameter may be aliased with any output parameter.
!>
!>  Barring over/underflow and assuming a guard digit in subtraction, all
!>  output quantities are correct to within a few units in the last
!>  place (ulps).
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> 

Definition at line 137 of file slasv2.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      REAL               CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      parameter( zero = 0.0e0 )
      REAL               HALF
      parameter( half = 0.5e0 )
      REAL               ONE
      parameter( one = 1.0e0 )
      REAL               TWO
      parameter( two = 2.0e0 )
      REAL               FOUR
      parameter( four = 4.0e0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            GASMAL, SWAP
      INTEGER            PMAX
      REAL               A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
     $                   MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, sign, sqrt
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. Executable Statements ..
*
      ft = f
      fa = abs( ft )
      ht = h
      ha = abs( h )
*
*     PMAX points to the maximum absolute element of matrix
*       PMAX = 1 if F largest in absolute values
*       PMAX = 2 if G largest in absolute values
*       PMAX = 3 if H largest in absolute values
*
      pmax = 1
      swap = ( ha.GT.fa )
      IF( swap ) THEN
         pmax = 3
         temp = ft
         ft = ht
         ht = temp
         temp = fa
         fa = ha
         ha = temp
*
*        Now FA .ge. HA
*
      END IF
      gt = g
      ga = abs( gt )
      IF( ga.EQ.zero ) THEN
*
*        Diagonal matrix
*
         ssmin = ha
         ssmax = fa
         clt = one
         crt = one
         slt = zero
         srt = zero
      ELSE
         gasmal = .true.
         IF( ga.GT.fa ) THEN
            pmax = 2
            IF( ( fa / ga ).LT.slamch( 'EPS' ) ) THEN
*
*              Case of very large GA
*
               gasmal = .false.
               ssmax = ga
               IF( ha.GT.one ) THEN
                  ssmin = fa / ( ga / ha )
               ELSE
                  ssmin = ( fa / ga )*ha
               END IF
               clt = one
               slt = ht / gt
               srt = one
               crt = ft / gt
            END IF
         END IF
         IF( gasmal ) THEN
*
*           Normal case
*
            d = fa - ha
            IF( d.EQ.fa ) THEN
*
*              Copes with infinite F or H
*
               l = one
            ELSE
               l = d / fa
            END IF
*
*           Note that 0 .le. L .le. 1
*
            m = gt / ft
*
*           Note that abs(M) .le. 1/macheps
*
            t = two - l
*
*           Note that T .ge. 1
*
            mm = m*m
            tt = t*t
            s = sqrt( tt+mm )
*
*           Note that 1 .le. S .le. 1 + 1/macheps
*
            IF( l.EQ.zero ) THEN
               r = abs( m )
            ELSE
               r = sqrt( l*l+mm )
            END IF
*
*           Note that 0 .le. R .le. 1 + 1/macheps
*
            a = half*( s+r )
*
*           Note that 1 .le. A .le. 1 + abs(M)
*
            ssmin = ha / a
            ssmax = fa*a
            IF( mm.EQ.zero ) THEN
*
*              Note that M is very tiny
*
               IF( l.EQ.zero ) THEN
                  t = sign( two, ft )*sign( one, gt )
               ELSE
                  t = gt / sign( d, ft ) + m / t
               END IF
            ELSE
               t = ( m / ( s+t )+m / ( r+l ) )*( one+a )
            END IF
            l = sqrt( t*t+four )
            crt = two / l
            srt = t / l
            clt = ( crt+srt*m ) / a
            slt = ( ht / ft )*srt / a
         END IF
      END IF
      IF( swap ) THEN
         csl = srt
         snl = crt
         csr = slt
         snr = clt
      ELSE
         csl = clt
         snl = slt
         csr = crt
         snr = srt
      END IF
*
*     Correct signs of SSMAX and SSMIN
*
      IF( pmax.EQ.1 )
     $   tsign = sign( one, csr )*sign( one, csl )*sign( one, f )
      IF( pmax.EQ.2 )
     $   tsign = sign( one, snr )*sign( one, csl )*sign( one, g )
      IF( pmax.EQ.3 )
     $   tsign = sign( one, snr )*sign( one, snl )*sign( one, h )
      ssmax = sign( ssmax, tsign )
      ssmin = sign( ssmin, tsign*sign( one, f )*sign( one, h ) )
      RETURN
*
*     End of SLASV2
*

xerbla()

subroutine xerbla	(	character*(*)	srname,
		integer	info )

XERBLA

Download XERBLA + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> XERBLA  is an error handler for the LAPACK routines.
!> It is called by an LAPACK routine if an input parameter has an
!> invalid value.  A message is printed and execution stops.
!>
!> Installers may consider modifying the STOP statement in order to
!> call system-specific exception-handling facilities.
!> 

Parameters

[in]	SRNAME	!> SRNAME is CHARACTER*(*) !> The name of the routine which called XERBLA. !>
[in]	INFO	!> INFO is INTEGER !> The position of the invalid parameter in the parameter list !> of the calling routine. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 69 of file xerbla.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER*(*)      SRNAME
      INTEGER            INFO
*     ..
*
* =====================================================================
*
*     .. Intrinsic Functions ..
      INTRINSIC          len_trim
*     ..
*     .. Executable Statements ..
*
      WRITE( *, fmt = 9999 )srname( 1:len_trim( srname ) ), info
*
      stop
*
 9999 FORMAT( ' ** On entry to ', a, ' parameter number ', i2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*

xerbla_array()

subroutine xerbla_array	(	character(1), dimension(srname_len)	srname_array,
		integer	srname_len,
		integer	info )

XERBLA_ARRAY

Download XERBLA_ARRAY + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK
!> and BLAS error handler.  Rather than taking a Fortran string argument
!> as the function's name, XERBLA_ARRAY takes an array of single
!> characters along with the array's length.  XERBLA_ARRAY then copies
!> up to 32 characters of that array into a Fortran string and passes
!> that to XERBLA.  If called with a non-positive SRNAME_LEN,
!> XERBLA_ARRAY will call XERBLA with a string of all blank characters.
!>
!> Say some macro or other device makes XERBLA_ARRAY available to C99
!> by a name lapack_xerbla and with a common Fortran calling convention.
!> Then a C99 program could invoke XERBLA via:
!>    {
!>      int flen = strlen(__func__);
!>      lapack_xerbla(__func__, &flen, &info);
!>    }
!>
!> Providing XERBLA_ARRAY is not necessary for intercepting LAPACK
!> errors.  XERBLA_ARRAY calls XERBLA.
!> 

Parameters

[in]	SRNAME_ARRAY	!> SRNAME_ARRAY is CHARACTER(1) array, dimension (SRNAME_LEN) !> The name of the routine which called XERBLA_ARRAY. !>
[in]	SRNAME_LEN	!> SRNAME_LEN is INTEGER !> The length of the name in SRNAME_ARRAY. !>
[in]	INFO	!> INFO is INTEGER !> The position of the invalid parameter in the parameter list !> of the calling routine. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Definition at line 89 of file xerbla_array.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER SRNAME_LEN, INFO
*     ..
*     .. Array Arguments ..
      CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN)
*     ..
*
* =====================================================================
*
*     ..
*     .. Local Scalars ..
      INTEGER I
*     ..
*     .. Local Arrays ..
      CHARACTER*32 SRNAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC min, len
*     ..
*     .. External Functions ..
      EXTERNAL xerbla
*     ..
*     .. Executable Statements ..
      srname = ''
      DO i = 1, min( srname_len, len( srname ) )
         srname( i:i ) = srname_array( i )
      END DO
 
      CALL xerbla( srname, info )
 
      RETURN

zlartg()

subroutine zlartg	(	complex(wp)	f,
		complex(wp)	g,
		real(wp)	c,
		complex(wp)	s,
		complex(wp)	r )

ZLARTG generates a plane rotation with real cosine and complex sine.

Purpose:

!>
!> ZLARTG generates a plane rotation so that
!>
!>    [  C         S  ] . [ F ]  =  [ R ]
!>    [ -conjg(S)  C  ]   [ G ]     [ 0 ]
!>
!> where C is real and C**2 + |S|**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>
!>    sgn(x) = {  x / |x|,   x != 0
!>             {  1,         x = 0
!>
!>    R = sgn(F) * sqrt(|F|**2 + |G|**2)
!>
!>    C = |F| / sqrt(|F|**2 + |G|**2)
!>
!>    S = sgn(F) * conjg(G) / sqrt(|F|**2 + |G|**2)
!>
!> When F and G are real, the formulas simplify to C = F/R and
!> S = G/R, and the returned values of C, S, and R should be
!> identical to those returned by DLARTG.
!>
!> The algorithm used to compute these quantities incorporates scaling
!> to avoid overflow or underflow in computing the square root of the
!> sum of squares.
!>
!> This is a faster version of the BLAS1 routine ZROTG, except for
!> the following differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0, then C=0 and S is chosen so that R is real.
!>
!> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
!> 

Parameters

[in]	F	!> F is COMPLEX(wp) !> The first component of vector to be rotated. !>
[in]	G	!> G is COMPLEX(wp) !> The second component of vector to be rotated. !>
[out]	C	!> C is REAL(wp) !> The cosine of the rotation. !>
[out]	S	!> S is COMPLEX(wp) !> The sine of the rotation. !>
[out]	R	!> R is COMPLEX(wp) !> The nonzero component of the rotated vector. !>

Author

Edward Anderson, Lockheed Martin

Date

August 2016

Contributors:

Weslley Pereira, University of Colorado Denver, USA

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> 

Definition at line 117 of file zlartg.f90.

   use la_constants, &
   only: wp=>dp, zero=>dzero, one=>done, two=>dtwo, czero=>zzero, &
         rtmin=>drtmin, rtmax=>drtmax, safmin=>dsafmin, safmax=>dsafmax
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp)           c
   complex(wp)        f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
   complex(wp) :: fs, gs, t
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, aimag, conjg, max, min, real, sqrt
!  ..
!  .. Statement Functions ..
   real(wp) :: ABSSQ
!  ..
!  .. Statement Function definitions ..
   abssq( t ) = real( t )**2 + aimag( t )**2
!  ..
!  .. Executable Statements ..
!
   if( g == czero ) then
      c = one
      s = czero
      r = f
   else if( f == czero ) then
      c = zero
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         g2 = abssq( g )
         d = sqrt( g2 )
         s = conjg( g ) / d
         r = d
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = abssq( gs )
         d = sqrt( g2 )
         s = conjg( gs ) / d
         r = d*u
      end if
   else
      f1 = max( abs(real(f)), abs(aimag(f)) )
      g1 = max( abs(real(g)), abs(aimag(g)) )
      if( f1 > rtmin .and. f1 < rtmax .and. &
          g1 > rtmin .and. g1 < rtmax ) then
!
!        Use unscaled algorithm
!
         f2 = abssq( f )
         g2 = abssq( g )
         h2 = f2 + g2
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = f2*p
         s = conjg( g )*( f*p )
         r = f*( h2*p )
      else
!
!        Use scaled algorithm
!
         u = min( safmax, max( safmin, f1, g1 ) )
         uu = one / u
         gs = g*uu
         g2 = abssq( gs )
         if( f1*uu < rtmin ) then
!
!           f is not well-scaled when scaled by g1.
!           Use a different scaling for f.
!
            v = min( safmax, max( safmin, f1 ) )
            vv = one / v
            w = v * uu
            fs = f*vv
            f2 = abssq( fs )
            h2 = f2*w**2 + g2
         else
!
!           Otherwise use the same scaling for f and g.
!
            w = one
            fs = f*uu
            f2 = abssq( fs )
            h2 = f2 + g2
         end if
         if( f2 > rtmin .and. h2 < rtmax ) then
            d = sqrt( f2*h2 )
         else
            d = sqrt( f2 )*sqrt( h2 )
         end if
         p = 1 / d
         c = ( f2*p )*w
         s = conjg( gs )*( fs*p )
         r = ( fs*( h2*p ) )*u
      end if
   end if
   return

zlassq()

subroutine zlassq	(	integer	n,
		complex(wp), dimension(*)	x,
		integer	incx,
		real(wp)	scl,
		real(wp)	sumsq )

ZLASSQ updates a sum of squares represented in scaled form.

Download ZLASSQ + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> ZLASSQ  returns the values  scl  and  smsq  such that
!>
!>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
!>
!> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scl and smsq are overwritten on SCALE and SUMSQ respectively.
!>
!> If scale * sqrt( sumsq ) > tbig then
!>    we require:   scale >= sqrt( TINY*EPS ) / sbig   on entry,
!> and if 0 < scale * sqrt( sumsq ) < tsml then
!>    we require:   scale <= sqrt( HUGE ) / ssml       on entry,
!> where
!>    tbig -- upper threshold for values whose square is representable;
!>    sbig -- scaling constant for big numbers; \see la_constants.f90
!>    tsml -- lower threshold for values whose square is representable;
!>    ssml -- scaling constant for small numbers; \see la_constants.f90
!> and
!>    TINY*EPS -- tiniest representable number;
!>    HUGE     -- biggest representable number.
!>
!> 

Parameters

[in]	N	!> N is INTEGER !> The number of elements to be used from the vector x. !>
[in]	X	!> X is DOUBLE COMPLEX array, dimension (1+(N-1)*abs(INCX)) !> The vector for which a scaled sum of squares is computed. !> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. !>
[in]	INCX	!> INCX is INTEGER !> The increment between successive values of the vector x. !> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n !> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n !> If INCX = 0, x isn't a vector so there is no need to call !> this subroutine. If you call it anyway, it will count x(1) !> in the vector norm N times. !>
[in,out]	SCALE	!> SCALE is DOUBLE PRECISION !> On entry, the value scale in the equation above. !> On exit, SCALE is overwritten with scl , the scaling factor !> for the sum of squares. !>
[in,out]	SUMSQ	!> SUMSQ is DOUBLE PRECISION !> On entry, the value sumsq in the equation above. !> On exit, SUMSQ is overwritten with smsq , the basic sum of !> squares from which scl has been factored out. !>

Author

Edward Anderson, Lockheed Martin

Contributors:

Weslley Pereira, University of Colorado Denver, USA Nick Papior, Technical University of Denmark, DK

Further Details:

!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!>  Blue, James L. (1978)
!>  A Portable Fortran Program to Find the Euclidean Norm of a Vector
!>  ACM Trans Math Softw 4:15--23
!>  https://doi.org/10.1145/355769.355771
!>
!> 

Definition at line 136 of file zlassq.f90.

   use la_constants, &
      only: wp=>dp, zero=>dzero, one=>done, &
            sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml
   use la_xisnan
!
!  -- LAPACK auxiliary routine --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
!  .. Scalar Arguments ..
   integer :: incx, n
   real(wp) :: scl, sumsq
!  ..
!  .. Array Arguments ..
   complex(wp) :: x(*)
!  ..
!  .. Local Scalars ..
   integer :: i, ix
   logical :: notbig
   real(wp) :: abig, amed, asml, ax, ymax, ymin
!  ..
!
!  Quick return if possible
!
   if( la_isnan(scl) .or. la_isnan(sumsq) ) return
   if( sumsq == zero ) scl = one
   if( scl == zero ) then
      scl = one
      sumsq = zero
   end if
   if (n <= 0) then
      return
   end if
!
!  Compute the sum of squares in 3 accumulators:
!     abig -- sums of squares scaled down to avoid overflow
!     asml -- sums of squares scaled up to avoid underflow
!     amed -- sums of squares that do not require scaling
!  The thresholds and multipliers are
!     tbig -- values bigger than this are scaled down by sbig
!     tsml -- values smaller than this are scaled up by ssml
!
   notbig = .true.
   asml = zero
   amed = zero
   abig = zero
   ix = 1
   if( incx < 0 ) ix = 1 - (n-1)*incx
   do i = 1, n
      ax = abs(real(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ax = abs(aimag(x(ix)))
      if (ax > tbig) then
         abig = abig + (ax*sbig)**2
         notbig = .false.
      else if (ax < tsml) then
         if (notbig) asml = asml + (ax*ssml)**2
      else
         amed = amed + ax**2
      end if
      ix = ix + incx
   end do
!
!  Put the existing sum of squares into one of the accumulators
!
   if( sumsq > zero ) then
      ax = scl*sqrt( sumsq )
      if (ax > tbig) then
!        We assume scl >= sqrt( TINY*EPS ) / sbig
         abig = abig + (scl*sbig)**2 * sumsq
      else if (ax < tsml) then
!        We assume scl <= sqrt( HUGE ) / ssml
         if (notbig) asml = asml + (scl*ssml)**2 * sumsq
      else
         amed = amed + scl**2 * sumsq
      end if
   end if
!
!  Combine abig and amed or amed and asml if more than one
!  accumulator was used.
!
   if (abig > zero) then
!
!     Combine abig and amed if abig > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         abig = abig + (amed*sbig)*sbig
      end if
      scl = one / sbig
      sumsq = abig
   else if (asml > zero) then
!
!     Combine amed and asml if asml > 0.
!
      if (amed > zero .or. la_isnan(amed)) then
         amed = sqrt(amed)
         asml = sqrt(asml) / ssml
         if (asml > amed) then
            ymin = amed
            ymax = asml
         else
            ymin = asml
            ymax = amed
         end if
         scl = one
         sumsq = ymax**2*( one + (ymin/ymax)**2 )
      else
         scl = one / ssml
         sumsq = asml
      end if
   else
!
!     Otherwise all values are mid-range or zero
!
      scl = one
      sumsq = amed
   end if
   return