OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
auxiliary Computational routines
LAPACK » Other Computational Routines

Functions

program __secondtst_f__
 SECONDTST
program __slamchtst_f__
 SLAMCHTST
character *1 function chla_transtype (trans)
 CHLA_TRANSTYPE
subroutine dbdsdc (uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, info)
 DBDSDC
subroutine dbdsqr (uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
 DBDSQR
subroutine ddisna (job, m, n, d, sep, info)
 DDISNA
subroutine dlaed0 (icompq, qsiz, n, d, e, q, ldq, qstore, ldqs, work, iwork, info)
 DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
subroutine dlaed1 (n, d, q, ldq, indxq, rho, cutpnt, work, iwork, info)
 DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal.
subroutine dlaed2 (k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, info)
 DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.
subroutine dlaed3 (k, n, n1, d, q, ldq, rho, dlamda, q2, indx, ctot, w, s, info)
 DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.
subroutine dlaed4 (n, i, d, z, delta, rho, dlam, info)
 DLAED4 used by DSTEDC. Finds a single root of the secular equation.
subroutine dlaed5 (i, d, z, delta, rho, dlam)
 DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation.
subroutine dlaed6 (kniter, orgati, rho, d, z, finit, tau, info)
 DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation.
subroutine dlaed7 (icompq, n, qsiz, tlvls, curlvl, curpbm, d, q, ldq, indxq, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, info)
 DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
subroutine dlaed8 (icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt, z, dlamda, q2, ldq2, w, perm, givptr, givcol, givnum, indxp, indx, info)
 DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
subroutine dlaed9 (k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, s, lds, info)
 DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.
subroutine dlaeda (n, tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, info)
 DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense.
subroutine dlagtf (n, a, lambda, b, c, tol, d, in, info)
 DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.
subroutine dlamrg (n1, n2, a, dtrd1, dtrd2, index)
 DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.
subroutine dlartgs (x, y, sigma, cs, sn)
 DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
subroutine dlasq1 (n, d, e, work, info)
 DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
subroutine dlasq2 (n, z, info)
 DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.
subroutine dlasq3 (i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)
 DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.
subroutine dlasq4 (i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
 DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.
subroutine dlasq5 (i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn, dnm1, dnm2, ieee, eps)
 DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
subroutine dlasq6 (i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
 DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
subroutine dlasrt (id, n, d, info)
 DLASRT sorts numbers in increasing or decreasing order.
subroutine dstebz (range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
 DSTEBZ
subroutine dstedc (compz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
 DSTEDC
subroutine dsteqr (compz, n, d, e, z, ldz, work, info)
 DSTEQR
subroutine dsterf (n, d, e, info)
 DSTERF
integer function iladiag (diag)
 ILADIAG
integer function ilaprec (prec)
 ILAPREC
integer function ilatrans (trans)
 ILATRANS
integer function ilauplo (uplo)
 ILAUPLO
subroutine sbdsdc (uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, info)
 SBDSDC
subroutine sbdsqr (uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
 SBDSQR
subroutine sdisna (job, m, n, d, sep, info)
 SDISNA
subroutine slaed0 (icompq, qsiz, n, d, e, q, ldq, qstore, ldqs, work, iwork, info)
 SLAED0 used by SSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.
subroutine slaed1 (n, d, q, ldq, indxq, rho, cutpnt, work, iwork, info)
 SLAED1 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal.
subroutine slaed2 (k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, info)
 SLAED2 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.
subroutine slaed3 (k, n, n1, d, q, ldq, rho, dlamda, q2, indx, ctot, w, s, info)
 SLAED3 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.
subroutine slaed4 (n, i, d, z, delta, rho, dlam, info)
 SLAED4 used by SSTEDC. Finds a single root of the secular equation.
subroutine slaed5 (i, d, z, delta, rho, dlam)
 SLAED5 used by SSTEDC. Solves the 2-by-2 secular equation.
subroutine slaed6 (kniter, orgati, rho, d, z, finit, tau, info)
 SLAED6 used by SSTEDC. Computes one Newton step in solution of the secular equation.
subroutine slaed7 (icompq, n, qsiz, tlvls, curlvl, curpbm, d, q, ldq, indxq, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, info)
 SLAED7 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.
subroutine slaed8 (icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt, z, dlamda, q2, ldq2, w, perm, givptr, givcol, givnum, indxp, indx, info)
 SLAED8 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.
subroutine slaed9 (k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, s, lds, info)
 SLAED9 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.
subroutine slaeda (n, tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, info)
 SLAEDA used by SSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense.
subroutine slagtf (n, a, lambda, b, c, tol, d, in, info)
 SLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.
subroutine slamrg (n1, n2, a, strd1, strd2, index)
 SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.
subroutine slartgs (x, y, sigma, cs, sn)
 SLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
subroutine slasq1 (n, d, e, work, info)
 SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
subroutine slasq2 (n, z, info)
 SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.
subroutine slasq3 (i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)
 SLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.
subroutine slasq4 (i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
 SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.
subroutine slasq5 (i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn, dnm1, dnm2, ieee, eps)
  SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
subroutine slasq6 (i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
 SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
subroutine slasrt (id, n, d, info)
 SLASRT sorts numbers in increasing or decreasing order.
subroutine spttrf (n, d, e, info)
 SPTTRF
subroutine sstebz (range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
 SSTEBZ
subroutine sstedc (compz, n, d, e, z, ldz, work, lwork, iwork, liwork, info)
 SSTEDC
subroutine ssteqr (compz, n, d, e, z, ldz, work, info)
 SSTEQR
subroutine ssterf (n, d, e, info)
 SSTERF

Detailed Description

This is the group of auxiliary Computational routines

Function Documentation

◆ __secondtst_f__()

program __secondtst_f__

SECONDTST

Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 30 of file secondtst.f.

30 INTEGER NMAX, ITS

◆ __slamchtst_f__()

program __slamchtst_f__

SLAMCHTST

Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 28 of file slamchtst.f.

28 REAL BASE, EMAX, EMIN, EPS, RMAX, RMIN, RND, SFMIN,
29 $ T, PREC

◆ chla_transtype()

character*1 function chla_transtype ( integer trans)

CHLA_TRANSTYPE

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

Purpose:
!>
!> This subroutine translates from a BLAST-specified integer constant to
!> the character string specifying a transposition operation.
!>
!> CHLA_TRANSTYPE returns an CHARACTER*1.  If CHLA_TRANSTYPE is 'X',
!> then input is not an integer indicating a transposition operator.
!> Otherwise CHLA_TRANSTYPE returns the constant value corresponding to
!> TRANS.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file chla_transtype.f.

58*
59* -- LAPACK computational routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 INTEGER TRANS
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS
71 parameter( blas_no_trans = 111, blas_trans = 112,
72 $ blas_conj_trans = 113 )
73* ..
74* .. Executable Statements ..
75 IF( trans.EQ.blas_no_trans ) THEN
76 chla_transtype = 'N'
77 ELSE IF( trans.EQ.blas_trans ) THEN
78 chla_transtype = 'T'
79 ELSE IF( trans.EQ.blas_conj_trans ) THEN
80 chla_transtype = 'C'
81 ELSE
82 chla_transtype = 'X'
83 END IF
84 RETURN
85*
86* End of CHLA_TRANSTYPE
87*
chla_transtype
character *1 function chla_transtype(trans)
CHLA_TRANSTYPE
Definition chla_transtype.f:58

◆ dbdsdc()

subroutine dbdsdc ( character uplo,
character compq,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldu, * ) u,
integer ldu,
double precision, dimension( ldvt, * ) vt,
integer ldvt,
double precision, dimension( * ) q,
integer, dimension( * ) iq,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DBDSDC

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

Purpose:
!>
!> DBDSDC computes the singular value decomposition (SVD) of a real
!> N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
!> using a divide and conquer method, where S is a diagonal matrix
!> with non-negative diagonal elements (the singular values of B), and
!> U and VT are orthogonal matrices of left and right singular vectors,
!> respectively. DBDSDC can be used to compute all singular values,
!> and optionally, singular vectors or singular vectors in compact form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See DLASD3 for details.
!>
!> The code currently calls DLASDQ if singular values only are desired.
!> However, it can be slightly modified to compute singular values
!> using the divide and conquer method.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal.
!>          = 'L':  B is lower bidiagonal.
!>
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          Specifies whether singular vectors are to be computed
!>          as follows:
!>          = 'N':  Compute singular values only;
!>          = 'P':  Compute singular values and compute singular
!>                  vectors in compact form;
!>          = 'I':  Compute singular values and singular vectors.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the elements of E contain the offdiagonal
!>          elements of the bidiagonal matrix whose SVD is desired.
!>          On exit, E has been destroyed.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, U contains the left singular vectors
!>             of the bidiagonal matrix.
!>          For other values of COMPQ, U is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1.
!>          If singular vectors are desired, then LDU >= max( 1, N ).
!>
[out]VT
!>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, VT**T contains the right singular
!>             vectors of the bidiagonal matrix.
!>          For other values of COMPQ, VT is not referenced.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1.
!>          If singular vectors are desired, then LDVT >= max( 1, N ).
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, Q contains all the DOUBLE PRECISION data in
!>             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, Q is not referenced.
!>
[out]IQ
!>          IQ is INTEGER array, dimension (LDIQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, IQ contains all INTEGER data in
!>             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, IQ is not referenced.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          If COMPQ = 'N' then LWORK >= (4 * N).
!>          If COMPQ = 'P' then LWORK >= (6 * N).
!>          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (8*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute a singular value.
!>                The update process of divide and conquer failed.
!>
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 203 of file dbdsdc.f.

205*
206* -- LAPACK computational routine --
207* -- LAPACK is a software package provided by Univ. of Tennessee, --
208* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
209*
210* .. Scalar Arguments ..
211 CHARACTER COMPQ, UPLO
212 INTEGER INFO, LDU, LDVT, N
213* ..
214* .. Array Arguments ..
215 INTEGER IQ( * ), IWORK( * )
216 DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ),
217 $ VT( LDVT, * ), WORK( * )
218* ..
219*
220* =====================================================================
221* Changed dimension statement in comment describing E from (N) to
222* (N-1). Sven, 17 Feb 05.
223* =====================================================================
224*
225* .. Parameters ..
226 DOUBLE PRECISION ZERO, ONE, TWO
227 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
228* ..
229* .. Local Scalars ..
230 INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
231 $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
232 $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
233 $ SMLSZP, SQRE, START, WSTART, Z
234 DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN
235* ..
236* .. External Functions ..
237 LOGICAL LSAME
238 INTEGER ILAENV
239 DOUBLE PRECISION DLAMCH, DLANST
240 EXTERNAL lsame, ilaenv, dlamch, dlanst
241* ..
242* .. External Subroutines ..
243 EXTERNAL dcopy, dlartg, dlascl, dlasd0, dlasda, dlasdq,
244 $ dlaset, dlasr, dswap, xerbla
245* ..
246* .. Intrinsic Functions ..
247 INTRINSIC abs, dble, int, log, sign
248* ..
249* .. Executable Statements ..
250*
251* Test the input parameters.
252*
253 info = 0
254*
255 iuplo = 0
256 IF( lsame( uplo, 'U' ) )
257 $ iuplo = 1
258 IF( lsame( uplo, 'L' ) )
259 $ iuplo = 2
260 IF( lsame( compq, 'N' ) ) THEN
261 icompq = 0
262 ELSE IF( lsame( compq, 'P' ) ) THEN
263 icompq = 1
264 ELSE IF( lsame( compq, 'I' ) ) THEN
265 icompq = 2
266 ELSE
267 icompq = -1
268 END IF
269 IF( iuplo.EQ.0 ) THEN
270 info = -1
271 ELSE IF( icompq.LT.0 ) THEN
272 info = -2
273 ELSE IF( n.LT.0 ) THEN
274 info = -3
275 ELSE IF( ( ldu.LT.1 ) .OR. ( ( icompq.EQ.2 ) .AND. ( ldu.LT.
276 $ n ) ) ) THEN
277 info = -7
278 ELSE IF( ( ldvt.LT.1 ) .OR. ( ( icompq.EQ.2 ) .AND. ( ldvt.LT.
279 $ n ) ) ) THEN
280 info = -9
281 END IF
282 IF( info.NE.0 ) THEN
283 CALL xerbla( 'DBDSDC', -info )
284 RETURN
285 END IF
286*
287* Quick return if possible
288*
289 IF( n.EQ.0 )
290 $ RETURN
291 smlsiz = ilaenv( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
292 IF( n.EQ.1 ) THEN
293 IF( icompq.EQ.1 ) THEN
294 q( 1 ) = sign( one, d( 1 ) )
295 q( 1+smlsiz*n ) = one
296 ELSE IF( icompq.EQ.2 ) THEN
297 u( 1, 1 ) = sign( one, d( 1 ) )
298 vt( 1, 1 ) = one
299 END IF
300 d( 1 ) = abs( d( 1 ) )
301 RETURN
302 END IF
303 nm1 = n - 1
304*
305* If matrix lower bidiagonal, rotate to be upper bidiagonal
306* by applying Givens rotations on the left
307*
308 wstart = 1
309 qstart = 3
310 IF( icompq.EQ.1 ) THEN
311 CALL dcopy( n, d, 1, q( 1 ), 1 )
312 CALL dcopy( n-1, e, 1, q( n+1 ), 1 )
313 END IF
314 IF( iuplo.EQ.2 ) THEN
315 qstart = 5
316 IF( icompq .EQ. 2 ) wstart = 2*n - 1
317 DO 10 i = 1, n - 1
318 CALL dlartg( d( i ), e( i ), cs, sn, r )
319 d( i ) = r
320 e( i ) = sn*d( i+1 )
321 d( i+1 ) = cs*d( i+1 )
322 IF( icompq.EQ.1 ) THEN
323 q( i+2*n ) = cs
324 q( i+3*n ) = sn
325 ELSE IF( icompq.EQ.2 ) THEN
326 work( i ) = cs
327 work( nm1+i ) = -sn
328 END IF
329 10 CONTINUE
330 END IF
331*
332* If ICOMPQ = 0, use DLASDQ to compute the singular values.
333*
334 IF( icompq.EQ.0 ) THEN
335* Ignore WSTART, instead using WORK( 1 ), since the two vectors
336* for CS and -SN above are added only if ICOMPQ == 2,
337* and adding them exceeds documented WORK size of 4*n.
338 CALL dlasdq( 'U', 0, n, 0, 0, 0, d, e, vt, ldvt, u, ldu, u,
339 $ ldu, work( 1 ), info )
340 GO TO 40
341 END IF
342*
343* If N is smaller than the minimum divide size SMLSIZ, then solve
344* the problem with another solver.
345*
346 IF( n.LE.smlsiz ) THEN
347 IF( icompq.EQ.2 ) THEN
348 CALL dlaset( 'A', n, n, zero, one, u, ldu )
349 CALL dlaset( 'A', n, n, zero, one, vt, ldvt )
350 CALL dlasdq( 'U', 0, n, n, n, 0, d, e, vt, ldvt, u, ldu, u,
351 $ ldu, work( wstart ), info )
352 ELSE IF( icompq.EQ.1 ) THEN
353 iu = 1
354 ivt = iu + n
355 CALL dlaset( 'A', n, n, zero, one, q( iu+( qstart-1 )*n ),
356 $ n )
357 CALL dlaset( 'A', n, n, zero, one, q( ivt+( qstart-1 )*n ),
358 $ n )
359 CALL dlasdq( 'U', 0, n, n, n, 0, d, e,
360 $ q( ivt+( qstart-1 )*n ), n,
361 $ q( iu+( qstart-1 )*n ), n,
362 $ q( iu+( qstart-1 )*n ), n, work( wstart ),
363 $ info )
364 END IF
365 GO TO 40
366 END IF
367*
368 IF( icompq.EQ.2 ) THEN
369 CALL dlaset( 'A', n, n, zero, one, u, ldu )
370 CALL dlaset( 'A', n, n, zero, one, vt, ldvt )
371 END IF
372*
373* Scale.
374*
375 orgnrm = dlanst( 'M', n, d, e )
376 IF( orgnrm.EQ.zero )
377 $ RETURN
378 CALL dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, ierr )
379 CALL dlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, ierr )
380*
381 eps = (0.9d+0)*dlamch( 'Epsilon' )
382*
383 mlvl = int( log( dble( n ) / dble( smlsiz+1 ) ) / log( two ) ) + 1
384 smlszp = smlsiz + 1
385*
386 IF( icompq.EQ.1 ) THEN
387 iu = 1
388 ivt = 1 + smlsiz
389 difl = ivt + smlszp
390 difr = difl + mlvl
391 z = difr + mlvl*2
392 ic = z + mlvl
393 is = ic + 1
394 poles = is + 1
395 givnum = poles + 2*mlvl
396*
397 k = 1
398 givptr = 2
399 perm = 3
400 givcol = perm + mlvl
401 END IF
402*
403 DO 20 i = 1, n
404 IF( abs( d( i ) ).LT.eps ) THEN
405 d( i ) = sign( eps, d( i ) )
406 END IF
407 20 CONTINUE
408*
409 start = 1
410 sqre = 0
411*
412 DO 30 i = 1, nm1
413 IF( ( abs( e( i ) ).LT.eps ) .OR. ( i.EQ.nm1 ) ) THEN
414*
415* Subproblem found. First determine its size and then
416* apply divide and conquer on it.
417*
418 IF( i.LT.nm1 ) THEN
419*
420* A subproblem with E(I) small for I < NM1.
421*
422 nsize = i - start + 1
423 ELSE IF( abs( e( i ) ).GE.eps ) THEN
424*
425* A subproblem with E(NM1) not too small but I = NM1.
426*
427 nsize = n - start + 1
428 ELSE
429*
430* A subproblem with E(NM1) small. This implies an
431* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
432* first.
433*
434 nsize = i - start + 1
435 IF( icompq.EQ.2 ) THEN
436 u( n, n ) = sign( one, d( n ) )
437 vt( n, n ) = one
438 ELSE IF( icompq.EQ.1 ) THEN
439 q( n+( qstart-1 )*n ) = sign( one, d( n ) )
440 q( n+( smlsiz+qstart-1 )*n ) = one
441 END IF
442 d( n ) = abs( d( n ) )
443 END IF
444 IF( icompq.EQ.2 ) THEN
445 CALL dlasd0( nsize, sqre, d( start ), e( start ),
446 $ u( start, start ), ldu, vt( start, start ),
447 $ ldvt, smlsiz, iwork, work( wstart ), info )
448 ELSE
449 CALL dlasda( icompq, smlsiz, nsize, sqre, d( start ),
450 $ e( start ), q( start+( iu+qstart-2 )*n ), n,
451 $ q( start+( ivt+qstart-2 )*n ),
452 $ iq( start+k*n ), q( start+( difl+qstart-2 )*
453 $ n ), q( start+( difr+qstart-2 )*n ),
454 $ q( start+( z+qstart-2 )*n ),
455 $ q( start+( poles+qstart-2 )*n ),
456 $ iq( start+givptr*n ), iq( start+givcol*n ),
457 $ n, iq( start+perm*n ),
458 $ q( start+( givnum+qstart-2 )*n ),
459 $ q( start+( ic+qstart-2 )*n ),
460 $ q( start+( is+qstart-2 )*n ),
461 $ work( wstart ), iwork, info )
462 END IF
463 IF( info.NE.0 ) THEN
464 RETURN
465 END IF
466 start = i + 1
467 END IF
468 30 CONTINUE
469*
470* Unscale
471*
472 CALL dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr )
473 40 CONTINUE
474*
475* Use Selection Sort to minimize swaps of singular vectors
476*
477 DO 60 ii = 2, n
478 i = ii - 1
479 kk = i
480 p = d( i )
481 DO 50 j = ii, n
482 IF( d( j ).GT.p ) THEN
483 kk = j
484 p = d( j )
485 END IF
486 50 CONTINUE
487 IF( kk.NE.i ) THEN
488 d( kk ) = d( i )
489 d( i ) = p
490 IF( icompq.EQ.1 ) THEN
491 iq( i ) = kk
492 ELSE IF( icompq.EQ.2 ) THEN
493 CALL dswap( n, u( 1, i ), 1, u( 1, kk ), 1 )
494 CALL dswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt )
495 END IF
496 ELSE IF( icompq.EQ.1 ) THEN
497 iq( i ) = i
498 END IF
499 60 CONTINUE
500*
501* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
502*
503 IF( icompq.EQ.1 ) THEN
504 IF( iuplo.EQ.1 ) THEN
505 iq( n ) = 1
506 ELSE
507 iq( n ) = 0
508 END IF
509 END IF
510*
511* If B is lower bidiagonal, update U by those Givens rotations
512* which rotated B to be upper bidiagonal
513*
514 IF( ( iuplo.EQ.2 ) .AND. ( icompq.EQ.2 ) )
515 $ CALL dlasr( 'L', 'V', 'B', n, n, work( 1 ), work( n ), u, ldu )
516*
517 RETURN
518*
519* End of DBDSDC
520*
dlasd0
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 of...
Definition dlasd0.f:150
dlasdq
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....
Definition dlasdq.f:211
dlartg
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:113
dlanst
double precision function dlanst(norm, n, d, e)
DLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlanst.f:100
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
dlascl
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.
Definition dlascl.f:143
dlaset
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.
Definition dlaset.f:110
dlasr
subroutine dlasr(side, pivot, direct, m, n, c, s, a, lda)
DLASR applies a sequence of plane rotations to a general rectangular matrix.
Definition dlasr.f:199
dlasda
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 diagona...
Definition dlasda.f:273
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69

◆ dbdsqr()

subroutine dbdsqr ( character uplo,
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 )

DBDSQR

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

Purpose:
!>
!> DBDSQR computes the singular values and, optionally, the right and/or
!> left singular vectors from the singular value decomposition (SVD) of
!> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
!> zero-shift QR algorithm.  The SVD of B has the form
!>
!>    B = Q * S * P**T
!>
!> where S is the diagonal matrix of singular values, Q is an orthogonal
!> matrix of left singular vectors, and P is an orthogonal matrix of
!> right singular vectors.  If left singular vectors are requested, this
!> subroutine actually returns U*Q instead of Q, and, if right singular
!> vectors are requested, this subroutine returns P**T*VT instead of
!> P**T, for given real input matrices U and VT.  When U and VT are the
!> orthogonal matrices that reduce a general matrix A to bidiagonal
!> form:  A = U*B*VT, as computed by DGEBRD, then
!>
!>    A = (U*Q) * S * (P**T*VT)
!>
!> is the SVD of A.  Optionally, the subroutine may also compute Q**T*C
!> for a given real input matrix C.
!>
!> See  by J. Demmel and W. Kahan,
!> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
!> no. 5, pp. 873-912, Sept 1990) and
!>  by
!> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
!> Department, University of California at Berkeley, July 1992
!> for a detailed description of the algorithm.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal;
!>          = 'L':  B is lower bidiagonal.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!>
[in]NCVT
!>          NCVT is INTEGER
!>          The number of columns of the matrix VT. NCVT >= 0.
!>
[in]NRU
!>          NRU is INTEGER
!>          The number of rows of the matrix U. NRU >= 0.
!>
[in]NCC
!>          NCC is INTEGER
!>          The number of columns of the matrix C. NCC >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B in decreasing
!>          order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the N-1 offdiagonal elements of the bidiagonal
!>          matrix B.
!>          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
!>          will contain the diagonal and superdiagonal elements 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, an N-by-NCVT matrix VT.
!>          On exit, VT is overwritten by P**T * VT.
!>          Not referenced if NCVT = 0.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
!>
[in,out]U
!>          U is DOUBLE PRECISION array, dimension (LDU, N)
!>          On entry, an NRU-by-N matrix U.
!>          On exit, U is overwritten by U * Q.
!>          Not referenced if NRU = 0.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,NRU).
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC, NCC)
!>          On entry, an N-by-NCC matrix C.
!>          On exit, C is overwritten by Q**T * C.
!>          Not referenced if NCC = 0.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.
!>          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*(N-1))
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  If INFO = -i, the i-th argument had an illegal value
!>          > 0:
!>             if NCVT = NRU = NCC = 0,
!>                = 1, a split was marked by a positive value in E
!>                = 2, current block of Z not diagonalized after 30*N
!>                     iterations (in inner while loop)
!>                = 3, termination criterion of outer while loop not met
!>                     (program created more than N unreduced blocks)
!>             else NCVT = NRU = NCC = 0,
!>                   the algorithm did not converge; D and E contain the
!>                   elements of a bidiagonal matrix which is orthogonally
!>                   similar to the input matrix B;  if INFO = i, i
!>                   elements of E have not converged to zero.
!>
Internal Parameters:
!>  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          If it is positive, TOLMUL*EPS is the desired relative
!>             precision in the computed singular values.
!>          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
!>             desired absolute accuracy in the computed singular
!>             values (corresponds to relative accuracy
!>             abs(TOLMUL*EPS) in the largest singular value.
!>          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
!>             between 10 (for fast convergence) and .1/EPS
!>             (for there to be some accuracy in the results).
!>          Default is to lose at either one eighth or 2 of the
!>             available decimal digits in each computed singular value
!>             (whichever is smaller).
!>
!>  MAXITR  INTEGER, default = 6
!>          MAXITR controls the maximum number of passes of the
!>          algorithm through its inner loop. The algorithms stops
!>          (and so fails to converge) if the number of passes
!>          through the inner loop exceeds MAXITR*N**2.
!>
!>
Note:
!>  Bug report from Cezary Dendek.
!>  On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is
!>  removed since it can overflow pretty easily (for N larger or equal
!>  than 18,919). We instead use MAXITDIVN = MAXITR*N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 239 of file dbdsqr.f.

241*
242* -- LAPACK computational routine --
243* -- LAPACK is a software package provided by Univ. of Tennessee, --
244* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
245*
246* .. Scalar Arguments ..
247 CHARACTER UPLO
248 INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
249* ..
250* .. Array Arguments ..
251 DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
252 $ VT( LDVT, * ), WORK( * )
253* ..
254*
255* =====================================================================
256*
257* .. Parameters ..
258 DOUBLE PRECISION ZERO
259 parameter( zero = 0.0d0 )
260 DOUBLE PRECISION ONE
261 parameter( one = 1.0d0 )
262 DOUBLE PRECISION NEGONE
263 parameter( negone = -1.0d0 )
264 DOUBLE PRECISION HNDRTH
265 parameter( hndrth = 0.01d0 )
266 DOUBLE PRECISION TEN
267 parameter( ten = 10.0d0 )
268 DOUBLE PRECISION HNDRD
269 parameter( hndrd = 100.0d0 )
270 DOUBLE PRECISION MEIGTH
271 parameter( meigth = -0.125d0 )
272 INTEGER MAXITR
273 parameter( maxitr = 6 )
274* ..
275* .. Local Scalars ..
276 LOGICAL LOWER, ROTATE
277 INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M,
278 $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM
279 DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
280 $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
281 $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
282 $ SN, THRESH, TOL, TOLMUL, UNFL
283* ..
284* .. External Functions ..
285 LOGICAL LSAME
286 DOUBLE PRECISION DLAMCH
287 EXTERNAL lsame, dlamch
288* ..
289* .. External Subroutines ..
290 EXTERNAL dlartg, dlas2, dlasq1, dlasr, dlasv2, drot,
291 $ dscal, dswap, xerbla
292* ..
293* .. Intrinsic Functions ..
294 INTRINSIC abs, dble, max, min, sign, sqrt
295* ..
296* .. Executable Statements ..
297*
298* Test the input parameters.
299*
300 info = 0
301 lower = lsame( uplo, 'L' )
302 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lower ) THEN
303 info = -1
304 ELSE IF( n.LT.0 ) THEN
305 info = -2
306 ELSE IF( ncvt.LT.0 ) THEN
307 info = -3
308 ELSE IF( nru.LT.0 ) THEN
309 info = -4
310 ELSE IF( ncc.LT.0 ) THEN
311 info = -5
312 ELSE IF( ( ncvt.EQ.0 .AND. ldvt.LT.1 ) .OR.
313 $ ( ncvt.GT.0 .AND. ldvt.LT.max( 1, n ) ) ) THEN
314 info = -9
315 ELSE IF( ldu.LT.max( 1, nru ) ) THEN
316 info = -11
317 ELSE IF( ( ncc.EQ.0 .AND. ldc.LT.1 ) .OR.
318 $ ( ncc.GT.0 .AND. ldc.LT.max( 1, n ) ) ) THEN
319 info = -13
320 END IF
321 IF( info.NE.0 ) THEN
322 CALL xerbla( 'DBDSQR', -info )
323 RETURN
324 END IF
325 IF( n.EQ.0 )
326 $ RETURN
327 IF( n.EQ.1 )
328 $ GO TO 160
329*
330* ROTATE is true if any singular vectors desired, false otherwise
331*
332 rotate = ( ncvt.GT.0 ) .OR. ( nru.GT.0 ) .OR. ( ncc.GT.0 )
333*
334* If no singular vectors desired, use qd algorithm
335*
336 IF( .NOT.rotate ) THEN
337 CALL dlasq1( n, d, e, work, info )
338*
339* If INFO equals 2, dqds didn't finish, try to finish
340*
341 IF( info .NE. 2 ) RETURN
342 info = 0
343 END IF
344*
345 nm1 = n - 1
346 nm12 = nm1 + nm1
347 nm13 = nm12 + nm1
348 idir = 0
349*
350* Get machine constants
351*
352 eps = dlamch( 'Epsilon' )
353 unfl = dlamch( 'Safe minimum' )
354*
355* If matrix lower bidiagonal, rotate to be upper bidiagonal
356* by applying Givens rotations on the left
357*
358 IF( lower ) THEN
359 DO 10 i = 1, n - 1
360 CALL dlartg( d( i ), e( i ), cs, sn, r )
361 d( i ) = r
362 e( i ) = sn*d( i+1 )
363 d( i+1 ) = cs*d( i+1 )
364 work( i ) = cs
365 work( nm1+i ) = sn
366 10 CONTINUE
367*
368* Update singular vectors if desired
369*
370 IF( nru.GT.0 )
371 $ CALL dlasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,
372 $ ldu )
373 IF( ncc.GT.0 )
374 $ CALL dlasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,
375 $ ldc )
376 END IF
377*
378* Compute singular values to relative accuracy TOL
379* (By setting TOL to be negative, algorithm will compute
380* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
381*
382 tolmul = max( ten, min( hndrd, eps**meigth ) )
383 tol = tolmul*eps
384*
385* Compute approximate maximum, minimum singular values
386*
387 smax = zero
388 DO 20 i = 1, n
389 smax = max( smax, abs( d( i ) ) )
390 20 CONTINUE
391 DO 30 i = 1, n - 1
392 smax = max( smax, abs( e( i ) ) )
393 30 CONTINUE
394 sminl = zero
395 IF( tol.GE.zero ) THEN
396*
397* Relative accuracy desired
398*
399 sminoa = abs( d( 1 ) )
400 IF( sminoa.EQ.zero )
401 $ GO TO 50
402 mu = sminoa
403 DO 40 i = 2, n
404 mu = abs( d( i ) )*( mu / ( mu+abs( e( i-1 ) ) ) )
405 sminoa = min( sminoa, mu )
406 IF( sminoa.EQ.zero )
407 $ GO TO 50
408 40 CONTINUE
409 50 CONTINUE
410 sminoa = sminoa / sqrt( dble( n ) )
411 thresh = max( tol*sminoa, maxitr*(n*(n*unfl)) )
412 ELSE
413*
414* Absolute accuracy desired
415*
416 thresh = max( abs( tol )*smax, maxitr*(n*(n*unfl)) )
417 END IF
418*
419* Prepare for main iteration loop for the singular values
420* (MAXIT is the maximum number of passes through the inner
421* loop permitted before nonconvergence signalled.)
422*
423 maxitdivn = maxitr*n
424 iterdivn = 0
425 iter = -1
426 oldll = -1
427 oldm = -1
428*
429* M points to last element of unconverged part of matrix
430*
431 m = n
432*
433* Begin main iteration loop
434*
435 60 CONTINUE
436*
437* Check for convergence or exceeding iteration count
438*
439 IF( m.LE.1 )
440 $ GO TO 160
441*
442 IF( iter.GE.n ) THEN
443 iter = iter - n
444 iterdivn = iterdivn + 1
445 IF( iterdivn.GE.maxitdivn )
446 $ GO TO 200
447 END IF
448*
449* Find diagonal block of matrix to work on
450*
451 IF( tol.LT.zero .AND. abs( d( m ) ).LE.thresh )
452 $ d( m ) = zero
453 smax = abs( d( m ) )
454 smin = smax
455 DO 70 lll = 1, m - 1
456 ll = m - lll
457 abss = abs( d( ll ) )
458 abse = abs( e( ll ) )
459 IF( tol.LT.zero .AND. abss.LE.thresh )
460 $ d( ll ) = zero
461 IF( abse.LE.thresh )
462 $ GO TO 80
463 smin = min( smin, abss )
464 smax = max( smax, abss, abse )
465 70 CONTINUE
466 ll = 0
467 GO TO 90
468 80 CONTINUE
469 e( ll ) = zero
470*
471* Matrix splits since E(LL) = 0
472*
473 IF( ll.EQ.m-1 ) THEN
474*
475* Convergence of bottom singular value, return to top of loop
476*
477 m = m - 1
478 GO TO 60
479 END IF
480 90 CONTINUE
481 ll = ll + 1
482*
483* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
484*
485 IF( ll.EQ.m-1 ) THEN
486*
487* 2 by 2 block, handle separately
488*
489 CALL dlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,
490 $ cosr, sinl, cosl )
491 d( m-1 ) = sigmx
492 e( m-1 ) = zero
493 d( m ) = sigmn
494*
495* Compute singular vectors, if desired
496*
497 IF( ncvt.GT.0 )
498 $ CALL drot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,
499 $ sinr )
500 IF( nru.GT.0 )
501 $ CALL drot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl )
502 IF( ncc.GT.0 )
503 $ CALL drot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,
504 $ sinl )
505 m = m - 2
506 GO TO 60
507 END IF
508*
509* If working on new submatrix, choose shift direction
510* (from larger end diagonal element towards smaller)
511*
512 IF( ll.GT.oldm .OR. m.LT.oldll ) THEN
513 IF( abs( d( ll ) ).GE.abs( d( m ) ) ) THEN
514*
515* Chase bulge from top (big end) to bottom (small end)
516*
517 idir = 1
518 ELSE
519*
520* Chase bulge from bottom (big end) to top (small end)
521*
522 idir = 2
523 END IF
524 END IF
525*
526* Apply convergence tests
527*
528 IF( idir.EQ.1 ) THEN
529*
530* Run convergence test in forward direction
531* First apply standard test to bottom of matrix
532*
533 IF( abs( e( m-1 ) ).LE.abs( tol )*abs( d( m ) ) .OR.
534 $ ( tol.LT.zero .AND. abs( e( m-1 ) ).LE.thresh ) ) THEN
535 e( m-1 ) = zero
536 GO TO 60
537 END IF
538*
539 IF( tol.GE.zero ) THEN
540*
541* If relative accuracy desired,
542* apply convergence criterion forward
543*
544 mu = abs( d( ll ) )
545 sminl = mu
546 DO 100 lll = ll, m - 1
547 IF( abs( e( lll ) ).LE.tol*mu ) THEN
548 e( lll ) = zero
549 GO TO 60
550 END IF
551 mu = abs( d( lll+1 ) )*( mu / ( mu+abs( e( lll ) ) ) )
552 sminl = min( sminl, mu )
553 100 CONTINUE
554 END IF
555*
556 ELSE
557*
558* Run convergence test in backward direction
559* First apply standard test to top of matrix
560*
561 IF( abs( e( ll ) ).LE.abs( tol )*abs( d( ll ) ) .OR.
562 $ ( tol.LT.zero .AND. abs( e( ll ) ).LE.thresh ) ) THEN
563 e( ll ) = zero
564 GO TO 60
565 END IF
566*
567 IF( tol.GE.zero ) THEN
568*
569* If relative accuracy desired,
570* apply convergence criterion backward
571*
572 mu = abs( d( m ) )
573 sminl = mu
574 DO 110 lll = m - 1, ll, -1
575 IF( abs( e( lll ) ).LE.tol*mu ) THEN
576 e( lll ) = zero
577 GO TO 60
578 END IF
579 mu = abs( d( lll ) )*( mu / ( mu+abs( e( lll ) ) ) )
580 sminl = min( sminl, mu )
581 110 CONTINUE
582 END IF
583 END IF
584 oldll = ll
585 oldm = m
586*
587* Compute shift. First, test if shifting would ruin relative
588* accuracy, and if so set the shift to zero.
589*
590 IF( tol.GE.zero .AND. n*tol*( sminl / smax ).LE.
591 $ max( eps, hndrth*tol ) ) THEN
592*
593* Use a zero shift to avoid loss of relative accuracy
594*
595 shift = zero
596 ELSE
597*
598* Compute the shift from 2-by-2 block at end of matrix
599*
600 IF( idir.EQ.1 ) THEN
601 sll = abs( d( ll ) )
602 CALL dlas2( d( m-1 ), e( m-1 ), d( m ), shift, r )
603 ELSE
604 sll = abs( d( m ) )
605 CALL dlas2( d( ll ), e( ll ), d( ll+1 ), shift, r )
606 END IF
607*
608* Test if shift negligible, and if so set to zero
609*
610 IF( sll.GT.zero ) THEN
611 IF( ( shift / sll )**2.LT.eps )
612 $ shift = zero
613 END IF
614 END IF
615*
616* Increment iteration count
617*
618 iter = iter + m - ll
619*
620* If SHIFT = 0, do simplified QR iteration
621*
622 IF( shift.EQ.zero ) THEN
623 IF( idir.EQ.1 ) THEN
624*
625* Chase bulge from top to bottom
626* Save cosines and sines for later singular vector updates
627*
628 cs = one
629 oldcs = one
630 DO 120 i = ll, m - 1
631 CALL dlartg( d( i )*cs, e( i ), cs, sn, r )
632 IF( i.GT.ll )
633 $ e( i-1 ) = oldsn*r
634 CALL dlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) )
635 work( i-ll+1 ) = cs
636 work( i-ll+1+nm1 ) = sn
637 work( i-ll+1+nm12 ) = oldcs
638 work( i-ll+1+nm13 ) = oldsn
639 120 CONTINUE
640 h = d( m )*cs
641 d( m ) = h*oldcs
642 e( m-1 ) = h*oldsn
643*
644* Update singular vectors
645*
646 IF( ncvt.GT.0 )
647 $ CALL dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),
648 $ work( n ), vt( ll, 1 ), ldvt )
649 IF( nru.GT.0 )
650 $ CALL dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),
651 $ work( nm13+1 ), u( 1, ll ), ldu )
652 IF( ncc.GT.0 )
653 $ CALL dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),
654 $ work( nm13+1 ), c( ll, 1 ), ldc )
655*
656* Test convergence
657*
658 IF( abs( e( m-1 ) ).LE.thresh )
659 $ e( m-1 ) = zero
660*
661 ELSE
662*
663* Chase bulge from bottom to top
664* Save cosines and sines for later singular vector updates
665*
666 cs = one
667 oldcs = one
668 DO 130 i = m, ll + 1, -1
669 CALL dlartg( d( i )*cs, e( i-1 ), cs, sn, r )
670 IF( i.LT.m )
671 $ e( i ) = oldsn*r
672 CALL dlartg( oldcs*r, d( i-1 )*sn, oldcs, oldsn, d( i ) )
673 work( i-ll ) = cs
674 work( i-ll+nm1 ) = -sn
675 work( i-ll+nm12 ) = oldcs
676 work( i-ll+nm13 ) = -oldsn
677 130 CONTINUE
678 h = d( ll )*cs
679 d( ll ) = h*oldcs
680 e( ll ) = h*oldsn
681*
682* Update singular vectors
683*
684 IF( ncvt.GT.0 )
685 $ CALL dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),
686 $ work( nm13+1 ), vt( ll, 1 ), ldvt )
687 IF( nru.GT.0 )
688 $ CALL dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),
689 $ work( n ), u( 1, ll ), ldu )
690 IF( ncc.GT.0 )
691 $ CALL dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),
692 $ work( n ), c( ll, 1 ), ldc )
693*
694* Test convergence
695*
696 IF( abs( e( ll ) ).LE.thresh )
697 $ e( ll ) = zero
698 END IF
699 ELSE
700*
701* Use nonzero shift
702*
703 IF( idir.EQ.1 ) THEN
704*
705* Chase bulge from top to bottom
706* Save cosines and sines for later singular vector updates
707*
708 f = ( abs( d( ll ) )-shift )*
709 $ ( sign( one, d( ll ) )+shift / d( ll ) )
710 g = e( ll )
711 DO 140 i = ll, m - 1
712 CALL dlartg( f, g, cosr, sinr, r )
713 IF( i.GT.ll )
714 $ e( i-1 ) = r
715 f = cosr*d( i ) + sinr*e( i )
716 e( i ) = cosr*e( i ) - sinr*d( i )
717 g = sinr*d( i+1 )
718 d( i+1 ) = cosr*d( i+1 )
719 CALL dlartg( f, g, cosl, sinl, r )
720 d( i ) = r
721 f = cosl*e( i ) + sinl*d( i+1 )
722 d( i+1 ) = cosl*d( i+1 ) - sinl*e( i )
723 IF( i.LT.m-1 ) THEN
724 g = sinl*e( i+1 )
725 e( i+1 ) = cosl*e( i+1 )
726 END IF
727 work( i-ll+1 ) = cosr
728 work( i-ll+1+nm1 ) = sinr
729 work( i-ll+1+nm12 ) = cosl
730 work( i-ll+1+nm13 ) = sinl
731 140 CONTINUE
732 e( m-1 ) = f
733*
734* Update singular vectors
735*
736 IF( ncvt.GT.0 )
737 $ CALL dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),
738 $ work( n ), vt( ll, 1 ), ldvt )
739 IF( nru.GT.0 )
740 $ CALL dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),
741 $ work( nm13+1 ), u( 1, ll ), ldu )
742 IF( ncc.GT.0 )
743 $ CALL dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),
744 $ work( nm13+1 ), c( ll, 1 ), ldc )
745*
746* Test convergence
747*
748 IF( abs( e( m-1 ) ).LE.thresh )
749 $ e( m-1 ) = zero
750*
751 ELSE
752*
753* Chase bulge from bottom to top
754* Save cosines and sines for later singular vector updates
755*
756 f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /
757 $ d( m ) )
758 g = e( m-1 )
759 DO 150 i = m, ll + 1, -1
760 CALL dlartg( f, g, cosr, sinr, r )
761 IF( i.LT.m )
762 $ e( i ) = r
763 f = cosr*d( i ) + sinr*e( i-1 )
764 e( i-1 ) = cosr*e( i-1 ) - sinr*d( i )
765 g = sinr*d( i-1 )
766 d( i-1 ) = cosr*d( i-1 )
767 CALL dlartg( f, g, cosl, sinl, r )
768 d( i ) = r
769 f = cosl*e( i-1 ) + sinl*d( i-1 )
770 d( i-1 ) = cosl*d( i-1 ) - sinl*e( i-1 )
771 IF( i.GT.ll+1 ) THEN
772 g = sinl*e( i-2 )
773 e( i-2 ) = cosl*e( i-2 )
774 END IF
775 work( i-ll ) = cosr
776 work( i-ll+nm1 ) = -sinr
777 work( i-ll+nm12 ) = cosl
778 work( i-ll+nm13 ) = -sinl
779 150 CONTINUE
780 e( ll ) = f
781*
782* Test convergence
783*
784 IF( abs( e( ll ) ).LE.thresh )
785 $ e( ll ) = zero
786*
787* Update singular vectors if desired
788*
789 IF( ncvt.GT.0 )
790 $ CALL dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),
791 $ work( nm13+1 ), vt( ll, 1 ), ldvt )
792 IF( nru.GT.0 )
793 $ CALL dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),
794 $ work( n ), u( 1, ll ), ldu )
795 IF( ncc.GT.0 )
796 $ CALL dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),
797 $ work( n ), c( ll, 1 ), ldc )
798 END IF
799 END IF
800*
801* QR iteration finished, go back and check convergence
802*
803 GO TO 60
804*
805* All singular values converged, so make them positive
806*
807 160 CONTINUE
808 DO 170 i = 1, n
809 IF( d( i ).LT.zero ) THEN
810 d( i ) = -d( i )
811*
812* Change sign of singular vectors, if desired
813*
814 IF( ncvt.GT.0 )
815 $ CALL dscal( ncvt, negone, vt( i, 1 ), ldvt )
816 END IF
817 170 CONTINUE
818*
819* Sort the singular values into decreasing order (insertion sort on
820* singular values, but only one transposition per singular vector)
821*
822 DO 190 i = 1, n - 1
823*
824* Scan for smallest D(I)
825*
826 isub = 1
827 smin = d( 1 )
828 DO 180 j = 2, n + 1 - i
829 IF( d( j ).LE.smin ) THEN
830 isub = j
831 smin = d( j )
832 END IF
833 180 CONTINUE
834 IF( isub.NE.n+1-i ) THEN
835*
836* Swap singular values and vectors
837*
838 d( isub ) = d( n+1-i )
839 d( n+1-i ) = smin
840 IF( ncvt.GT.0 )
841 $ CALL dswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),
842 $ ldvt )
843 IF( nru.GT.0 )
844 $ CALL dswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 )
845 IF( ncc.GT.0 )
846 $ CALL dswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc )
847 END IF
848 190 CONTINUE
849 GO TO 220
850*
851* Maximum number of iterations exceeded, failure to converge
852*
853 200 CONTINUE
854 info = 0
855 DO 210 i = 1, n - 1
856 IF( e( i ).NE.zero )
857 $ info = info + 1
858 210 CONTINUE
859 220 CONTINUE
860 RETURN
861*
862* End of DBDSQR
863*
dlas2
subroutine dlas2(f, g, h, ssmin, ssmax)
DLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition dlas2.f:107
dlasv2
subroutine dlasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition dlasv2.f:138
dlasq1
subroutine dlasq1(n, d, e, work, info)
DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
Definition dlasq1.f:108
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ ddisna()

subroutine ddisna ( character job,
integer m,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) sep,
integer info )

DDISNA

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

Purpose:
!>
!> DDISNA computes the reciprocal condition numbers for the eigenvectors
!> of a real symmetric or complex Hermitian matrix or for the left or
!> right singular vectors of a general m-by-n matrix. The reciprocal
!> condition number is the 'gap' between the corresponding eigenvalue or
!> singular value and the nearest other one.
!>
!> The bound on the error, measured by angle in radians, in the I-th
!> computed vector is given by
!>
!>        DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
!>
!> where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
!> to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
!> the error bound.
!>
!> DDISNA may also be used to compute error bounds for eigenvectors of
!> the generalized symmetric definite eigenproblem.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies for which problem the reciprocal condition numbers
!>          should be computed:
!>          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
!>          = 'L':  the left singular vectors of a general matrix;
!>          = 'R':  the right singular vectors of a general matrix.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          If JOB = 'L' or 'R', the number of columns of the matrix,
!>          in which case N >= 0. Ignored if JOB = 'E'.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (M) if JOB = 'E'
!>                              dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The eigenvalues (if JOB = 'E') or singular values (if JOB =
!>          'L' or 'R') of the matrix, in either increasing or decreasing
!>          order. If singular values, they must be non-negative.
!>
[out]SEP
!>          SEP is DOUBLE PRECISION array, dimension (M) if JOB = 'E'
!>                               dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The reciprocal condition numbers of the vectors.
!>
[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 116 of file ddisna.f.

117*
118* -- LAPACK computational routine --
119* -- LAPACK is a software package provided by Univ. of Tennessee, --
120* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
121*
122* .. Scalar Arguments ..
123 CHARACTER JOB
124 INTEGER INFO, M, N
125* ..
126* .. Array Arguments ..
127 DOUBLE PRECISION D( * ), SEP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 DOUBLE PRECISION ZERO
134 parameter( zero = 0.0d+0 )
135* ..
136* .. Local Scalars ..
137 LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
138 INTEGER I, K
139 DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 DOUBLE PRECISION DLAMCH
144 EXTERNAL lsame, dlamch
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, max, min
148* ..
149* .. External Subroutines ..
150 EXTERNAL xerbla
151* ..
152* .. Executable Statements ..
153*
154* Test the input arguments
155*
156 info = 0
157 eigen = lsame( job, 'E' )
158 left = lsame( job, 'L' )
159 right = lsame( job, 'R' )
160 sing = left .OR. right
161 IF( eigen ) THEN
162 k = m
163 ELSE IF( sing ) THEN
164 k = min( m, n )
165 END IF
166 IF( .NOT.eigen .AND. .NOT.sing ) THEN
167 info = -1
168 ELSE IF( m.LT.0 ) THEN
169 info = -2
170 ELSE IF( k.LT.0 ) THEN
171 info = -3
172 ELSE
173 incr = .true.
174 decr = .true.
175 DO 10 i = 1, k - 1
176 IF( incr )
177 $ incr = incr .AND. d( i ).LE.d( i+1 )
178 IF( decr )
179 $ decr = decr .AND. d( i ).GE.d( i+1 )
180 10 CONTINUE
181 IF( sing .AND. k.GT.0 ) THEN
182 IF( incr )
183 $ incr = incr .AND. zero.LE.d( 1 )
184 IF( decr )
185 $ decr = decr .AND. d( k ).GE.zero
186 END IF
187 IF( .NOT.( incr .OR. decr ) )
188 $ info = -4
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'DDISNA', -info )
192 RETURN
193 END IF
194*
195* Quick return if possible
196*
197 IF( k.EQ.0 )
198 $ RETURN
199*
200* Compute reciprocal condition numbers
201*
202 IF( k.EQ.1 ) THEN
203 sep( 1 ) = dlamch( 'O' )
204 ELSE
205 oldgap = abs( d( 2 )-d( 1 ) )
206 sep( 1 ) = oldgap
207 DO 20 i = 2, k - 1
208 newgap = abs( d( i+1 )-d( i ) )
209 sep( i ) = min( oldgap, newgap )
210 oldgap = newgap
211 20 CONTINUE
212 sep( k ) = oldgap
213 END IF
214 IF( sing ) THEN
215 IF( ( left .AND. m.GT.n ) .OR. ( right .AND. m.LT.n ) ) THEN
216 IF( incr )
217 $ sep( 1 ) = min( sep( 1 ), d( 1 ) )
218 IF( decr )
219 $ sep( k ) = min( sep( k ), d( k ) )
220 END IF
221 END IF
222*
223* Ensure that reciprocal condition numbers are not less than
224* threshold, in order to limit the size of the error bound
225*
226 eps = dlamch( 'E' )
227 safmin = dlamch( 'S' )
228 anorm = max( abs( d( 1 ) ), abs( d( k ) ) )
229 IF( anorm.EQ.zero ) THEN
230 thresh = eps
231 ELSE
232 thresh = max( eps*anorm, safmin )
233 END IF
234 DO 30 i = 1, k
235 sep( i ) = max( sep( i ), thresh )
236 30 CONTINUE
237*
238 RETURN
239*
240* End of DDISNA
241*

◆ dlaed0()

subroutine dlaed0 ( integer icompq,
integer qsiz,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision, dimension( ldqs, * ) qstore,
integer ldqs,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.

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

Purpose:
!>
!> DLAED0 computes all eigenvalues and corresponding eigenvectors of a
!> symmetric tridiagonal matrix using the divide and conquer method.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
!>                matrix.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the main diagonal of the tridiagonal matrix.
!>         On exit, its eigenvalues.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>         The off-diagonal elements of the tridiagonal matrix.
!>         On exit, E has been destroyed.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>         On entry, Q must contain an N-by-N orthogonal matrix.
!>         If ICOMPQ = 0    Q is not referenced.
!>         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
!>                          orthogonal matrix used to reduce the full
!>                          matrix to tridiagonal form corresponding to
!>                          the subset of the full matrix which is being
!>                          decomposed at this time.
!>         If ICOMPQ = 2    On entry, Q will be the identity matrix.
!>                          On exit, Q contains the eigenvectors of the
!>                          tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  If eigenvectors are
!>         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
!>
[out]QSTORE
!>          QSTORE is DOUBLE PRECISION array, dimension (LDQS, N)
!>         Referenced only when ICOMPQ = 1.  Used to store parts of
!>         the eigenvector matrix when the updating matrix multiplies
!>         take place.
!>
[in]LDQS
!>          LDQS is INTEGER
!>         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
!>         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array,
!>         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
!>                     1 + 3*N + 2*N*lg N + 3*N**2
!>                     ( lg( N ) = smallest integer k
!>                                 such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of WORK must be at least
!>                     4*N + N**2.
!>
[out]IWORK
!>          IWORK is INTEGER array,
!>         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
!>                        6 + 6*N + 5*N*lg N.
!>                        ( lg( N ) = smallest integer k
!>                                    such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of IWORK must be at least
!>                        3 + 5*N.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 170 of file dlaed0.f.

172*
173* -- LAPACK computational routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
179* ..
180* .. Array Arguments ..
181 INTEGER IWORK( * )
182 DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
183 $ WORK( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ZERO, ONE, TWO
190 parameter( zero = 0.d0, one = 1.d0, two = 2.d0 )
191* ..
192* .. Local Scalars ..
193 INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
194 $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
195 $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
196 $ SPM2, SUBMAT, SUBPBS, TLVLS
197 DOUBLE PRECISION TEMP
198* ..
199* .. External Subroutines ..
200 EXTERNAL dcopy, dgemm, dlacpy, dlaed1, dlaed7, dsteqr,
201 $ xerbla
202* ..
203* .. External Functions ..
204 INTEGER ILAENV
205 EXTERNAL ilaenv
206* ..
207* .. Intrinsic Functions ..
208 INTRINSIC abs, dble, int, log, max
209* ..
210* .. Executable Statements ..
211*
212* Test the input parameters.
213*
214 info = 0
215*
216 IF( icompq.LT.0 .OR. icompq.GT.2 ) THEN
217 info = -1
218 ELSE IF( ( icompq.EQ.1 ) .AND. ( qsiz.LT.max( 0, n ) ) ) THEN
219 info = -2
220 ELSE IF( n.LT.0 ) THEN
221 info = -3
222 ELSE IF( ldq.LT.max( 1, n ) ) THEN
223 info = -7
224 ELSE IF( ldqs.LT.max( 1, n ) ) THEN
225 info = -9
226 END IF
227 IF( info.NE.0 ) THEN
228 CALL xerbla( 'DLAED0', -info )
229 RETURN
230 END IF
231*
232* Quick return if possible
233*
234 IF( n.EQ.0 )
235 $ RETURN
236*
237 smlsiz = ilaenv( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
238*
239* Determine the size and placement of the submatrices, and save in
240* the leading elements of IWORK.
241*
242 iwork( 1 ) = n
243 subpbs = 1
244 tlvls = 0
245 10 CONTINUE
246 IF( iwork( subpbs ).GT.smlsiz ) THEN
247 DO 20 j = subpbs, 1, -1
248 iwork( 2*j ) = ( iwork( j )+1 ) / 2
249 iwork( 2*j-1 ) = iwork( j ) / 2
250 20 CONTINUE
251 tlvls = tlvls + 1
252 subpbs = 2*subpbs
253 GO TO 10
254 END IF
255 DO 30 j = 2, subpbs
256 iwork( j ) = iwork( j ) + iwork( j-1 )
257 30 CONTINUE
258*
259* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
260* using rank-1 modifications (cuts).
261*
262 spm1 = subpbs - 1
263 DO 40 i = 1, spm1
264 submat = iwork( i ) + 1
265 smm1 = submat - 1
266 d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
267 d( submat ) = d( submat ) - abs( e( smm1 ) )
268 40 CONTINUE
269*
270 indxq = 4*n + 3
271 IF( icompq.NE.2 ) THEN
272*
273* Set up workspaces for eigenvalues only/accumulate new vectors
274* routine
275*
276 temp = log( dble( n ) ) / log( two )
277 lgn = int( temp )
278 IF( 2**lgn.LT.n )
279 $ lgn = lgn + 1
280 IF( 2**lgn.LT.n )
281 $ lgn = lgn + 1
282 iprmpt = indxq + n + 1
283 iperm = iprmpt + n*lgn
284 iqptr = iperm + n*lgn
285 igivpt = iqptr + n + 2
286 igivcl = igivpt + n*lgn
287*
288 igivnm = 1
289 iq = igivnm + 2*n*lgn
290 iwrem = iq + n**2 + 1
291*
292* Initialize pointers
293*
294 DO 50 i = 0, subpbs
295 iwork( iprmpt+i ) = 1
296 iwork( igivpt+i ) = 1
297 50 CONTINUE
298 iwork( iqptr ) = 1
299 END IF
300*
301* Solve each submatrix eigenproblem at the bottom of the divide and
302* conquer tree.
303*
304 curr = 0
305 DO 70 i = 0, spm1
306 IF( i.EQ.0 ) THEN
307 submat = 1
308 matsiz = iwork( 1 )
309 ELSE
310 submat = iwork( i ) + 1
311 matsiz = iwork( i+1 ) - iwork( i )
312 END IF
313 IF( icompq.EQ.2 ) THEN
314 CALL dsteqr( 'I', matsiz, d( submat ), e( submat ),
315 $ q( submat, submat ), ldq, work, info )
316 IF( info.NE.0 )
317 $ GO TO 130
318 ELSE
319 CALL dsteqr( 'I', matsiz, d( submat ), e( submat ),
320 $ work( iq-1+iwork( iqptr+curr ) ), matsiz, work,
321 $ info )
322 IF( info.NE.0 )
323 $ GO TO 130
324 IF( icompq.EQ.1 ) THEN
325 CALL dgemm( 'N', 'N', qsiz, matsiz, matsiz, one,
326 $ q( 1, submat ), ldq, work( iq-1+iwork( iqptr+
327 $ curr ) ), matsiz, zero, qstore( 1, submat ),
328 $ ldqs )
329 END IF
330 iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2
331 curr = curr + 1
332 END IF
333 k = 1
334 DO 60 j = submat, iwork( i+1 )
335 iwork( indxq+j ) = k
336 k = k + 1
337 60 CONTINUE
338 70 CONTINUE
339*
340* Successively merge eigensystems of adjacent submatrices
341* into eigensystem for the corresponding larger matrix.
342*
343* while ( SUBPBS > 1 )
344*
345 curlvl = 1
346 80 CONTINUE
347 IF( subpbs.GT.1 ) THEN
348 spm2 = subpbs - 2
349 DO 90 i = 0, spm2, 2
350 IF( i.EQ.0 ) THEN
351 submat = 1
352 matsiz = iwork( 2 )
353 msd2 = iwork( 1 )
354 curprb = 0
355 ELSE
356 submat = iwork( i ) + 1
357 matsiz = iwork( i+2 ) - iwork( i )
358 msd2 = matsiz / 2
359 curprb = curprb + 1
360 END IF
361*
362* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
363* into an eigensystem of size MATSIZ.
364* DLAED1 is used only for the full eigensystem of a tridiagonal
365* matrix.
366* DLAED7 handles the cases in which eigenvalues only or eigenvalues
367* and eigenvectors of a full symmetric matrix (which was reduced to
368* tridiagonal form) are desired.
369*
370 IF( icompq.EQ.2 ) THEN
371 CALL dlaed1( matsiz, d( submat ), q( submat, submat ),
372 $ ldq, iwork( indxq+submat ),
373 $ e( submat+msd2-1 ), msd2, work,
374 $ iwork( subpbs+1 ), info )
375 ELSE
376 CALL dlaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,
377 $ d( submat ), qstore( 1, submat ), ldqs,
378 $ iwork( indxq+submat ), e( submat+msd2-1 ),
379 $ msd2, work( iq ), iwork( iqptr ),
380 $ iwork( iprmpt ), iwork( iperm ),
381 $ iwork( igivpt ), iwork( igivcl ),
382 $ work( igivnm ), work( iwrem ),
383 $ iwork( subpbs+1 ), info )
384 END IF
385 IF( info.NE.0 )
386 $ GO TO 130
387 iwork( i / 2+1 ) = iwork( i+2 )
388 90 CONTINUE
389 subpbs = subpbs / 2
390 curlvl = curlvl + 1
391 GO TO 80
392 END IF
393*
394* end while
395*
396* Re-merge the eigenvalues/vectors which were deflated at the final
397* merge step.
398*
399 IF( icompq.EQ.1 ) THEN
400 DO 100 i = 1, n
401 j = iwork( indxq+i )
402 work( i ) = d( j )
403 CALL dcopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 )
404 100 CONTINUE
405 CALL dcopy( n, work, 1, d, 1 )
406 ELSE IF( icompq.EQ.2 ) THEN
407 DO 110 i = 1, n
408 j = iwork( indxq+i )
409 work( i ) = d( j )
410 CALL dcopy( n, q( 1, j ), 1, work( n*i+1 ), 1 )
411 110 CONTINUE
412 CALL dcopy( n, work, 1, d, 1 )
413 CALL dlacpy( 'A', n, n, work( n+1 ), n, q, ldq )
414 ELSE
415 DO 120 i = 1, n
416 j = iwork( indxq+i )
417 work( i ) = d( j )
418 120 CONTINUE
419 CALL dcopy( n, work, 1, d, 1 )
420 END IF
421 GO TO 140
422*
423 130 CONTINUE
424 info = submat*( n+1 ) + submat + matsiz - 1
425*
426 140 CONTINUE
427 RETURN
428*
429* End of DLAED0
430*
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlaed7
subroutine dlaed7(icompq, n, qsiz, tlvls, curlvl, curpbm, d, q, ldq, indxq, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, info)
DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition dlaed7.f:260
dsteqr
subroutine dsteqr(compz, n, d, e, z, ldz, work, info)
DSTEQR
Definition dsteqr.f:131
dlaed1
subroutine dlaed1(n, d, q, ldq, indxq, rho, cutpnt, work, iwork, info)
DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition dlaed1.f:163
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ dlaed1()

subroutine dlaed1 ( integer n,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
double precision rho,
integer cutpnt,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DLAED1 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> DLAED1 computes the updated eigensystem of a diagonal
!> matrix after modification by a rank-one symmetric matrix.  This
!> routine is used only for the eigenproblem which requires all
!> eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles
!> the case in which eigenvalues only or eigenvalues and eigenvectors
!> of a full symmetric matrix (which was reduced to tridiagonal form)
!> are desired.
!>
!>   T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!>
!>    where Z = Q**T*u, u is a vector of length N with ones in the
!>    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!>
!>    The eigenvectors of the original matrix are stored in Q, and the
!>    eigenvalues are in D.  The algorithm consists of three stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple eigenvalues or if there is a zero in
!>       the Z vector.  For each such occurrence the dimension of the
!>       secular equation problem is reduced by one.  This stage is
!>       performed by the routine DLAED2.
!>
!>       The second stage consists of calculating the updated
!>       eigenvalues. This is done by finding the roots of the secular
!>       equation via the routine DLAED4 (as called by DLAED3).
!>       This routine also calculates the eigenvectors of the current
!>       problem.
!>
!>       The final stage consists of computing the updated eigenvectors
!>       directly using the updated eigenvalues.  The eigenvectors for
!>       the current problem are multiplied with the eigenvectors from
!>       the overall problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the eigenvalues of the rank-1-perturbed matrix.
!>         On exit, the eigenvalues of the repaired matrix.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,N)
!>         On entry, the eigenvectors of the rank-1-perturbed matrix.
!>         On exit, the eigenvectors of the repaired tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in,out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         On entry, the permutation which separately sorts the two
!>         subproblems in D into ascending order.
!>         On exit, the permutation which will reintegrate the
!>         subproblems back into sorted order,
!>         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>         The subdiagonal entry used to create the rank-1 modification.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         The location of the last eigenvalue in the leading sub-matrix.
!>         min(1,N) <= CUTPNT <= N/2.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*N + N**2)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 161 of file dlaed1.f.

163*
164* -- LAPACK computational routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 INTEGER CUTPNT, INFO, LDQ, N
170 DOUBLE PRECISION RHO
171* ..
172* .. Array Arguments ..
173 INTEGER INDXQ( * ), IWORK( * )
174 DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Local Scalars ..
180 INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
181 $ IW, IZ, K, N1, N2, ZPP1
182* ..
183* .. External Subroutines ..
184 EXTERNAL dcopy, dlaed2, dlaed3, dlamrg, xerbla
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC max, min
188* ..
189* .. Executable Statements ..
190*
191* Test the input parameters.
192*
193 info = 0
194*
195 IF( n.LT.0 ) THEN
196 info = -1
197 ELSE IF( ldq.LT.max( 1, n ) ) THEN
198 info = -4
199 ELSE IF( min( 1, n / 2 ).GT.cutpnt .OR. ( n / 2 ).LT.cutpnt ) THEN
200 info = -7
201 END IF
202 IF( info.NE.0 ) THEN
203 CALL xerbla( 'DLAED1', -info )
204 RETURN
205 END IF
206*
207* Quick return if possible
208*
209 IF( n.EQ.0 )
210 $ RETURN
211*
212* The following values are integer pointers which indicate
213* the portion of the workspace
214* used by a particular array in DLAED2 and DLAED3.
215*
216 iz = 1
217 idlmda = iz + n
218 iw = idlmda + n
219 iq2 = iw + n
220*
221 indx = 1
222 indxc = indx + n
223 coltyp = indxc + n
224 indxp = coltyp + n
225*
226*
227* Form the z-vector which consists of the last row of Q_1 and the
228* first row of Q_2.
229*
230 CALL dcopy( cutpnt, q( cutpnt, 1 ), ldq, work( iz ), 1 )
231 zpp1 = cutpnt + 1
232 CALL dcopy( n-cutpnt, q( zpp1, zpp1 ), ldq, work( iz+cutpnt ), 1 )
233*
234* Deflate eigenvalues.
235*
236 CALL dlaed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ),
237 $ work( idlmda ), work( iw ), work( iq2 ),
238 $ iwork( indx ), iwork( indxc ), iwork( indxp ),
239 $ iwork( coltyp ), info )
240*
241 IF( info.NE.0 )
242 $ GO TO 20
243*
244* Solve Secular Equation.
245*
246 IF( k.NE.0 ) THEN
247 is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt +
248 $ ( iwork( coltyp+1 )+iwork( coltyp+2 ) )*( n-cutpnt ) + iq2
249 CALL dlaed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ),
250 $ work( iq2 ), iwork( indxc ), iwork( coltyp ),
251 $ work( iw ), work( is ), info )
252 IF( info.NE.0 )
253 $ GO TO 20
254*
255* Prepare the INDXQ sorting permutation.
256*
257 n1 = k
258 n2 = n - k
259 CALL dlamrg( n1, n2, d, 1, -1, indxq )
260 ELSE
261 DO 10 i = 1, n
262 indxq( i ) = i
263 10 CONTINUE
264 END IF
265*
266 20 CONTINUE
267 RETURN
268*
269* End of DLAED1
270*
dlaed2
subroutine dlaed2(k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, info)
DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matri...
Definition dlaed2.f:212
dlamrg
subroutine dlamrg(n1, n2, a, dtrd1, dtrd2, index)
DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
Definition dlamrg.f:99
dlaed3
subroutine dlaed3(k, n, n1, d, q, ldq, rho, dlamda, q2, indx, ctot, w, s, info)
DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors....
Definition dlaed3.f:185

◆ dlaed2()

subroutine dlaed2 ( integer k,
integer n,
integer n1,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
double precision rho,
double precision, dimension( * ) z,
double precision, dimension( * ) dlamda,
double precision, dimension( * ) w,
double precision, dimension( * ) q2,
integer, dimension( * ) indx,
integer, dimension( * ) indxc,
integer, dimension( * ) indxp,
integer, dimension( * ) coltyp,
integer info )

DLAED2 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> DLAED2 merges the two sets of eigenvalues together into a single
!> sorted set.  Then it tries to deflate the size of the problem.
!> There are two ways in which deflation can occur:  when two or more
!> eigenvalues are close together or if there is a tiny entry in the
!> Z vector.  For each such occurrence the order of the related secular
!> equation problem is reduced by one.
!>
Parameters
[out]K
!>          K is INTEGER
!>         The number of non-deflated eigenvalues, and the order of the
!>         related secular equation. 0 <= K <=N.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]N1
!>          N1 is INTEGER
!>         The location of the last eigenvalue in the leading sub-matrix.
!>         min(1,N) <= N1 <= N/2.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, D contains the eigenvalues of the two submatrices to
!>         be combined.
!>         On exit, D contains the trailing (N-K) updated eigenvalues
!>         (those which were deflated) sorted into increasing order.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>         On entry, Q contains the eigenvectors of two submatrices in
!>         the two square blocks with corners at (1,1), (N1,N1)
!>         and (N1+1, N1+1), (N,N).
!>         On exit, Q contains the trailing (N-K) updated eigenvectors
!>         (those which were deflated) in its last N-K columns.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in,out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which separately sorts the two sub-problems
!>         in D into ascending order.  Note that elements in the second
!>         half of this permutation must first have N1 added to their
!>         values. Destroyed on exit.
!>
[in,out]RHO
!>          RHO is DOUBLE PRECISION
!>         On entry, the off-diagonal element associated with the rank-1
!>         cut which originally split the two submatrices which are now
!>         being recombined.
!>         On exit, RHO has been modified to the value required by
!>         DLAED3.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension (N)
!>         On entry, Z contains the updating vector (the last
!>         row of the first sub-eigenvector matrix and the first row of
!>         the second sub-eigenvector matrix).
!>         On exit, the contents of Z have been destroyed by the updating
!>         process.
!>
[out]DLAMDA
!>          DLAMDA is DOUBLE PRECISION array, dimension (N)
!>         A copy of the first K eigenvalues which will be used by
!>         DLAED3 to form the secular equation.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>         The first k values of the final deflation-altered z-vector
!>         which will be passed to DLAED3.
!>
[out]Q2
!>          Q2 is DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
!>         A copy of the first K eigenvectors which will be used by
!>         DLAED3 in a matrix multiply (DGEMM) to solve for the new
!>         eigenvectors.
!>
[out]INDX
!>          INDX is INTEGER array, dimension (N)
!>         The permutation used to sort the contents of DLAMDA into
!>         ascending order.
!>
[out]INDXC
!>          INDXC is INTEGER array, dimension (N)
!>         The permutation used to arrange the columns of the deflated
!>         Q matrix into three groups:  the first group contains non-zero
!>         elements only at and above N1, the second contains
!>         non-zero elements only below N1, and the third is dense.
!>
[out]INDXP
!>          INDXP is INTEGER array, dimension (N)
!>         The permutation used to place deflated values of D at the end
!>         of the array.  INDXP(1:K) points to the nondeflated D-values
!>         and INDXP(K+1:N) points to the deflated eigenvalues.
!>
[out]COLTYP
!>          COLTYP is INTEGER array, dimension (N)
!>         During execution, a label which will indicate which of the
!>         following types a column in the Q2 matrix is:
!>         1 : non-zero in the upper half only;
!>         2 : dense;
!>         3 : non-zero in the lower half only;
!>         4 : deflated.
!>         On exit, COLTYP(i) is the number of columns of type i,
!>         for i=1 to 4 only.
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 210 of file dlaed2.f.

212*
213* -- LAPACK computational routine --
214* -- LAPACK is a software package provided by Univ. of Tennessee, --
215* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216*
217* .. Scalar Arguments ..
218 INTEGER INFO, K, LDQ, N, N1
219 DOUBLE PRECISION RHO
220* ..
221* .. Array Arguments ..
222 INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
223 $ INDXQ( * )
224 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
225 $ W( * ), Z( * )
226* ..
227*
228* =====================================================================
229*
230* .. Parameters ..
231 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
232 parameter( mone = -1.0d0, zero = 0.0d0, one = 1.0d0,
233 $ two = 2.0d0, eight = 8.0d0 )
234* ..
235* .. Local Arrays ..
236 INTEGER CTOT( 4 ), PSM( 4 )
237* ..
238* .. Local Scalars ..
239 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
240 $ N2, NJ, PJ
241 DOUBLE PRECISION C, EPS, S, T, TAU, TOL
242* ..
243* .. External Functions ..
244 INTEGER IDAMAX
245 DOUBLE PRECISION DLAMCH, DLAPY2
246 EXTERNAL idamax, dlamch, dlapy2
247* ..
248* .. External Subroutines ..
249 EXTERNAL dcopy, dlacpy, dlamrg, drot, dscal, xerbla
250* ..
251* .. Intrinsic Functions ..
252 INTRINSIC abs, max, min, sqrt
253* ..
254* .. Executable Statements ..
255*
256* Test the input parameters.
257*
258 info = 0
259*
260 IF( n.LT.0 ) THEN
261 info = -2
262 ELSE IF( ldq.LT.max( 1, n ) ) THEN
263 info = -6
264 ELSE IF( min( 1, ( n / 2 ) ).GT.n1 .OR. ( n / 2 ).LT.n1 ) THEN
265 info = -3
266 END IF
267 IF( info.NE.0 ) THEN
268 CALL xerbla( 'DLAED2', -info )
269 RETURN
270 END IF
271*
272* Quick return if possible
273*
274 IF( n.EQ.0 )
275 $ RETURN
276*
277 n2 = n - n1
278 n1p1 = n1 + 1
279*
280 IF( rho.LT.zero ) THEN
281 CALL dscal( n2, mone, z( n1p1 ), 1 )
282 END IF
283*
284* Normalize z so that norm(z) = 1. Since z is the concatenation of
285* two normalized vectors, norm2(z) = sqrt(2).
286*
287 t = one / sqrt( two )
288 CALL dscal( n, t, z, 1 )
289*
290* RHO = ABS( norm(z)**2 * RHO )
291*
292 rho = abs( two*rho )
293*
294* Sort the eigenvalues into increasing order
295*
296 DO 10 i = n1p1, n
297 indxq( i ) = indxq( i ) + n1
298 10 CONTINUE
299*
300* re-integrate the deflated parts from the last pass
301*
302 DO 20 i = 1, n
303 dlamda( i ) = d( indxq( i ) )
304 20 CONTINUE
305 CALL dlamrg( n1, n2, dlamda, 1, 1, indxc )
306 DO 30 i = 1, n
307 indx( i ) = indxq( indxc( i ) )
308 30 CONTINUE
309*
310* Calculate the allowable deflation tolerance
311*
312 imax = idamax( n, z, 1 )
313 jmax = idamax( n, d, 1 )
314 eps = dlamch( 'Epsilon' )
315 tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
316*
317* If the rank-1 modifier is small enough, no more needs to be done
318* except to reorganize Q so that its columns correspond with the
319* elements in D.
320*
321 IF( rho*abs( z( imax ) ).LE.tol ) THEN
322 k = 0
323 iq2 = 1
324 DO 40 j = 1, n
325 i = indx( j )
326 CALL dcopy( n, q( 1, i ), 1, q2( iq2 ), 1 )
327 dlamda( j ) = d( i )
328 iq2 = iq2 + n
329 40 CONTINUE
330 CALL dlacpy( 'A', n, n, q2, n, q, ldq )
331 CALL dcopy( n, dlamda, 1, d, 1 )
332 GO TO 190
333 END IF
334*
335* If there are multiple eigenvalues then the problem deflates. Here
336* the number of equal eigenvalues are found. As each equal
337* eigenvalue is found, an elementary reflector is computed to rotate
338* the corresponding eigensubspace so that the corresponding
339* components of Z are zero in this new basis.
340*
341 DO 50 i = 1, n1
342 coltyp( i ) = 1
343 50 CONTINUE
344 DO 60 i = n1p1, n
345 coltyp( i ) = 3
346 60 CONTINUE
347*
348*
349 k = 0
350 k2 = n + 1
351 DO 70 j = 1, n
352 nj = indx( j )
353 IF( rho*abs( z( nj ) ).LE.tol ) THEN
354*
355* Deflate due to small z component.
356*
357 k2 = k2 - 1
358 coltyp( nj ) = 4
359 indxp( k2 ) = nj
360 IF( j.EQ.n )
361 $ GO TO 100
362 ELSE
363 pj = nj
364 GO TO 80
365 END IF
366 70 CONTINUE
367 80 CONTINUE
368 j = j + 1
369 nj = indx( j )
370 IF( j.GT.n )
371 $ GO TO 100
372 IF( rho*abs( z( nj ) ).LE.tol ) THEN
373*
374* Deflate due to small z component.
375*
376 k2 = k2 - 1
377 coltyp( nj ) = 4
378 indxp( k2 ) = nj
379 ELSE
380*
381* Check if eigenvalues are close enough to allow deflation.
382*
383 s = z( pj )
384 c = z( nj )
385*
386* Find sqrt(a**2+b**2) without overflow or
387* destructive underflow.
388*
389 tau = dlapy2( c, s )
390 t = d( nj ) - d( pj )
391 c = c / tau
392 s = -s / tau
393 IF( abs( t*c*s ).LE.tol ) THEN
394*
395* Deflation is possible.
396*
397 z( nj ) = tau
398 z( pj ) = zero
399 IF( coltyp( nj ).NE.coltyp( pj ) )
400 $ coltyp( nj ) = 2
401 coltyp( pj ) = 4
402 CALL drot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s )
403 t = d( pj )*c**2 + d( nj )*s**2
404 d( nj ) = d( pj )*s**2 + d( nj )*c**2
405 d( pj ) = t
406 k2 = k2 - 1
407 i = 1
408 90 CONTINUE
409 IF( k2+i.LE.n ) THEN
410 IF( d( pj ).LT.d( indxp( k2+i ) ) ) THEN
411 indxp( k2+i-1 ) = indxp( k2+i )
412 indxp( k2+i ) = pj
413 i = i + 1
414 GO TO 90
415 ELSE
416 indxp( k2+i-1 ) = pj
417 END IF
418 ELSE
419 indxp( k2+i-1 ) = pj
420 END IF
421 pj = nj
422 ELSE
423 k = k + 1
424 dlamda( k ) = d( pj )
425 w( k ) = z( pj )
426 indxp( k ) = pj
427 pj = nj
428 END IF
429 END IF
430 GO TO 80
431 100 CONTINUE
432*
433* Record the last eigenvalue.
434*
435 k = k + 1
436 dlamda( k ) = d( pj )
437 w( k ) = z( pj )
438 indxp( k ) = pj
439*
440* Count up the total number of the various types of columns, then
441* form a permutation which positions the four column types into
442* four uniform groups (although one or more of these groups may be
443* empty).
444*
445 DO 110 j = 1, 4
446 ctot( j ) = 0
447 110 CONTINUE
448 DO 120 j = 1, n
449 ct = coltyp( j )
450 ctot( ct ) = ctot( ct ) + 1
451 120 CONTINUE
452*
453* PSM(*) = Position in SubMatrix (of types 1 through 4)
454*
455 psm( 1 ) = 1
456 psm( 2 ) = 1 + ctot( 1 )
457 psm( 3 ) = psm( 2 ) + ctot( 2 )
458 psm( 4 ) = psm( 3 ) + ctot( 3 )
459 k = n - ctot( 4 )
460*
461* Fill out the INDXC array so that the permutation which it induces
462* will place all type-1 columns first, all type-2 columns next,
463* then all type-3's, and finally all type-4's.
464*
465 DO 130 j = 1, n
466 js = indxp( j )
467 ct = coltyp( js )
468 indx( psm( ct ) ) = js
469 indxc( psm( ct ) ) = j
470 psm( ct ) = psm( ct ) + 1
471 130 CONTINUE
472*
473* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
474* and Q2 respectively. The eigenvalues/vectors which were not
475* deflated go into the first K slots of DLAMDA and Q2 respectively,
476* while those which were deflated go into the last N - K slots.
477*
478 i = 1
479 iq1 = 1
480 iq2 = 1 + ( ctot( 1 )+ctot( 2 ) )*n1
481 DO 140 j = 1, ctot( 1 )
482 js = indx( i )
483 CALL dcopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
484 z( i ) = d( js )
485 i = i + 1
486 iq1 = iq1 + n1
487 140 CONTINUE
488*
489 DO 150 j = 1, ctot( 2 )
490 js = indx( i )
491 CALL dcopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
492 CALL dcopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
493 z( i ) = d( js )
494 i = i + 1
495 iq1 = iq1 + n1
496 iq2 = iq2 + n2
497 150 CONTINUE
498*
499 DO 160 j = 1, ctot( 3 )
500 js = indx( i )
501 CALL dcopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
502 z( i ) = d( js )
503 i = i + 1
504 iq2 = iq2 + n2
505 160 CONTINUE
506*
507 iq1 = iq2
508 DO 170 j = 1, ctot( 4 )
509 js = indx( i )
510 CALL dcopy( n, q( 1, js ), 1, q2( iq2 ), 1 )
511 iq2 = iq2 + n
512 z( i ) = d( js )
513 i = i + 1
514 170 CONTINUE
515*
516* The deflated eigenvalues and their corresponding vectors go back
517* into the last N - K slots of D and Q respectively.
518*
519 IF( k.LT.n ) THEN
520 CALL dlacpy( 'A', n, ctot( 4 ), q2( iq1 ), n,
521 $ q( 1, k+1 ), ldq )
522 CALL dcopy( n-k, z( k+1 ), 1, d( k+1 ), 1 )
523 END IF
524*
525* Copy CTOT into COLTYP for referencing in DLAED3.
526*
527 DO 180 j = 1, 4
528 coltyp( j ) = ctot( j )
529 180 CONTINUE
530*
531 190 CONTINUE
532 RETURN
533*
534* End of DLAED2
535*
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71

◆ dlaed3()

subroutine dlaed3 ( integer k,
integer n,
integer n1,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision rho,
double precision, dimension( * ) dlamda,
double precision, dimension( * ) q2,
integer, dimension( * ) indx,
integer, dimension( * ) ctot,
double precision, dimension( * ) w,
double precision, dimension( * ) s,
integer info )

DLAED3 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> DLAED3 finds the roots of the secular equation, as defined by the
!> values in D, W, and RHO, between 1 and K.  It makes the
!> appropriate calls to DLAED4 and then updates the eigenvectors by
!> multiplying the matrix of eigenvectors of the pair of eigensystems
!> being combined by the matrix of eigenvectors of the K-by-K system
!> which is solved here.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
Parameters
[in]K
!>          K is INTEGER
!>          The number of terms in the rational function to be solved by
!>          DLAED4.  K >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns in the Q matrix.
!>          N >= K (deflation may result in N>K).
!>
[in]N1
!>          N1 is INTEGER
!>          The location of the last eigenvalue in the leading submatrix.
!>          min(1,N) <= N1 <= N/2.
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          D(I) contains the updated eigenvalues for
!>          1 <= I <= K.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,N)
!>          Initially the first K columns are used as workspace.
!>          On output the columns 1 to K contain
!>          the updated eigenvectors.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>          The value of the parameter in the rank one update equation.
!>          RHO >= 0 required.
!>
[in,out]DLAMDA
!>          DLAMDA 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. May be changed on output by
!>          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
!>          Cray-2, or Cray C-90, as described above.
!>
[in]Q2
!>          Q2 is DOUBLE PRECISION array, dimension (LDQ2*N)
!>          The first K columns of this matrix contain the non-deflated
!>          eigenvectors for the split problem.
!>
[in]INDX
!>          INDX is INTEGER array, dimension (N)
!>          The permutation used to arrange the columns of the deflated
!>          Q matrix into three groups (see DLAED2).
!>          The rows of the eigenvectors found by DLAED4 must be likewise
!>          permuted before the matrix multiply can take place.
!>
[in]CTOT
!>          CTOT is INTEGER array, dimension (4)
!>          A count of the total number of the various types of columns
!>          in Q, as described in INDX.  The fourth column type is any
!>          column which has been deflated.
!>
[in,out]W
!>          W is DOUBLE PRECISION array, dimension (K)
!>          The first K elements of this array contain the components
!>          of the deflation-adjusted updating vector. Destroyed on
!>          output.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N1 + 1)*K
!>          Will contain the eigenvectors of the repaired matrix which
!>          will be multiplied by the previously accumulated eigenvectors
!>          to update the system.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = 1, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 183 of file dlaed3.f.

185*
186* -- LAPACK computational routine --
187* -- LAPACK is a software package provided by Univ. of Tennessee, --
188* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
189*
190* .. Scalar Arguments ..
191 INTEGER INFO, K, LDQ, N, N1
192 DOUBLE PRECISION RHO
193* ..
194* .. Array Arguments ..
195 INTEGER CTOT( * ), INDX( * )
196 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
197 $ S( * ), W( * )
198* ..
199*
200* =====================================================================
201*
202* .. Parameters ..
203 DOUBLE PRECISION ONE, ZERO
204 parameter( one = 1.0d0, zero = 0.0d0 )
205* ..
206* .. Local Scalars ..
207 INTEGER I, II, IQ2, J, N12, N2, N23
208 DOUBLE PRECISION TEMP
209* ..
210* .. External Functions ..
211 DOUBLE PRECISION DLAMC3, DNRM2
212 EXTERNAL dlamc3, dnrm2
213* ..
214* .. External Subroutines ..
215 EXTERNAL dcopy, dgemm, dlacpy, dlaed4, dlaset, xerbla
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC max, sign, sqrt
219* ..
220* .. Executable Statements ..
221*
222* Test the input parameters.
223*
224 info = 0
225*
226 IF( k.LT.0 ) THEN
227 info = -1
228 ELSE IF( n.LT.k ) THEN
229 info = -2
230 ELSE IF( ldq.LT.max( 1, n ) ) THEN
231 info = -6
232 END IF
233 IF( info.NE.0 ) THEN
234 CALL xerbla( 'DLAED3', -info )
235 RETURN
236 END IF
237*
238* Quick return if possible
239*
240 IF( k.EQ.0 )
241 $ RETURN
242*
243* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
244* be computed with high relative accuracy (barring over/underflow).
245* This is a problem on machines without a guard digit in
246* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
247* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
248* which on any of these machines zeros out the bottommost
249* bit of DLAMDA(I) if it is 1; this makes the subsequent
250* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
251* occurs. On binary machines with a guard digit (almost all
252* machines) it does not change DLAMDA(I) at all. On hexadecimal
253* and decimal machines with a guard digit, it slightly
254* changes the bottommost bits of DLAMDA(I). It does not account
255* for hexadecimal or decimal machines without guard digits
256* (we know of none). We use a subroutine call to compute
257* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
258* this code.
259*
260 DO 10 i = 1, k
261 dlamda( i ) = dlamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
262 10 CONTINUE
263*
264 DO 20 j = 1, k
265 CALL dlaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info )
266*
267* If the zero finder fails, the computation is terminated.
268*
269 IF( info.NE.0 )
270 $ GO TO 120
271 20 CONTINUE
272*
273 IF( k.EQ.1 )
274 $ GO TO 110
275 IF( k.EQ.2 ) THEN
276 DO 30 j = 1, k
277 w( 1 ) = q( 1, j )
278 w( 2 ) = q( 2, j )
279 ii = indx( 1 )
280 q( 1, j ) = w( ii )
281 ii = indx( 2 )
282 q( 2, j ) = w( ii )
283 30 CONTINUE
284 GO TO 110
285 END IF
286*
287* Compute updated W.
288*
289 CALL dcopy( k, w, 1, s, 1 )
290*
291* Initialize W(I) = Q(I,I)
292*
293 CALL dcopy( k, q, ldq+1, w, 1 )
294 DO 60 j = 1, k
295 DO 40 i = 1, j - 1
296 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
297 40 CONTINUE
298 DO 50 i = j + 1, k
299 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
300 50 CONTINUE
301 60 CONTINUE
302 DO 70 i = 1, k
303 w( i ) = sign( sqrt( -w( i ) ), s( i ) )
304 70 CONTINUE
305*
306* Compute eigenvectors of the modified rank-1 modification.
307*
308 DO 100 j = 1, k
309 DO 80 i = 1, k
310 s( i ) = w( i ) / q( i, j )
311 80 CONTINUE
312 temp = dnrm2( k, s, 1 )
313 DO 90 i = 1, k
314 ii = indx( i )
315 q( i, j ) = s( ii ) / temp
316 90 CONTINUE
317 100 CONTINUE
318*
319* Compute the updated eigenvectors.
320*
321 110 CONTINUE
322*
323 n2 = n - n1
324 n12 = ctot( 1 ) + ctot( 2 )
325 n23 = ctot( 2 ) + ctot( 3 )
326*
327 CALL dlacpy( 'A', n23, k, q( ctot( 1 )+1, 1 ), ldq, s, n23 )
328 iq2 = n1*n12 + 1
329 IF( n23.NE.0 ) THEN
330 CALL dgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,
331 $ zero, q( n1+1, 1 ), ldq )
332 ELSE
333 CALL dlaset( 'A', n2, k, zero, zero, q( n1+1, 1 ), ldq )
334 END IF
335*
336 CALL dlacpy( 'A', n12, k, q, ldq, s, n12 )
337 IF( n12.NE.0 ) THEN
338 CALL dgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,
339 $ ldq )
340 ELSE
341 CALL dlaset( 'A', n1, k, zero, zero, q( 1, 1 ), ldq )
342 END IF
343*
344*
345 120 CONTINUE
346 RETURN
347*
348* End of DLAED3
349*
dlaed4
subroutine dlaed4(n, i, d, z, delta, rho, dlam, info)
DLAED4 used by DSTEDC. Finds a single root of the secular equation.
Definition dlaed4.f:145
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89
dlamc3
double precision function dlamc3(a, b)
DLAMC3
Definition dlamch.f:169

◆ dlaed4()

subroutine dlaed4 ( integer n,
integer i,
double precision, dimension( * ) d,
double precision, dimension( * ) z,
double precision, dimension( * ) delta,
double precision rho,
double precision dlam,
integer info )

DLAED4 used by DSTEDC. Finds a single root of the secular equation.

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

Purpose:
!>
!> This subroutine computes the I-th updated eigenvalue of a symmetric
!> rank-one modification to a diagonal matrix whose elements are
!> given in the array d, and that
!>
!>            D(i) < D(j)  for  i < j
!>
!> and that RHO > 0.  This is arranged by the calling routine, and is
!> no loss in generality.  The rank-one modified system is thus
!>
!>            diag( D )  +  RHO * Z * Z_transpose.
!>
!> where we assume the Euclidean norm of Z is 1.
!>
!> The method consists of approximating the rational functions in the
!> secular equation by simpler interpolating rational functions.
!>
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, 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 > 2, DELTA contains (D(j) - lambda_I) in its  j-th
!>         component.  If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
!>         for detail. The vector DELTA contains the information necessary
!>         to construct the eigenvectors by DLAED3 and DLAED9.
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>         The scalar in the symmetric updating formula.
!>
[out]DLAM
!>          DLAM is DOUBLE PRECISION
!>         The computed lambda_I, the I-th updated eigenvalue.
!>
[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 144 of file dlaed4.f.

145*
146* -- LAPACK computational routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER I, INFO, N
152 DOUBLE PRECISION DLAM, RHO
153* ..
154* .. Array Arguments ..
155 DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 INTEGER MAXIT
162 parameter( maxit = 30 )
163 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
164 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
165 $ three = 3.0d0, four = 4.0d0, eight = 8.0d0,
166 $ ten = 10.0d0 )
167* ..
168* .. Local Scalars ..
169 LOGICAL ORGATI, SWTCH, SWTCH3
170 INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
171 DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
172 $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
173 $ RHOINV, TAU, TEMP, TEMP1, W
174* ..
175* .. Local Arrays ..
176 DOUBLE PRECISION ZZ( 3 )
177* ..
178* .. External Functions ..
179 DOUBLE PRECISION DLAMCH
180 EXTERNAL dlamch
181* ..
182* .. External Subroutines ..
183 EXTERNAL dlaed5, dlaed6
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, max, min, sqrt
187* ..
188* .. Executable Statements ..
189*
190* Since this routine is called in an inner loop, we do no argument
191* checking.
192*
193* Quick return for N=1 and 2.
194*
195 info = 0
196 IF( n.EQ.1 ) THEN
197*
198* Presumably, I=1 upon entry
199*
200 dlam = d( 1 ) + rho*z( 1 )*z( 1 )
201 delta( 1 ) = one
202 RETURN
203 END IF
204 IF( n.EQ.2 ) THEN
205 CALL dlaed5( i, d, z, delta, rho, dlam )
206 RETURN
207 END IF
208*
209* Compute machine epsilon
210*
211 eps = dlamch( 'Epsilon' )
212 rhoinv = one / rho
213*
214* The case I = N
215*
216 IF( i.EQ.n ) THEN
217*
218* Initialize some basic variables
219*
220 ii = n - 1
221 niter = 1
222*
223* Calculate initial guess
224*
225 midpt = rho / two
226*
227* If ||Z||_2 is not one, then TEMP should be set to
228* RHO * ||Z||_2^2 / TWO
229*
230 DO 10 j = 1, n
231 delta( j ) = ( d( j )-d( i ) ) - midpt
232 10 CONTINUE
233*
234 psi = zero
235 DO 20 j = 1, n - 2
236 psi = psi + z( j )*z( j ) / delta( j )
237 20 CONTINUE
238*
239 c = rhoinv + psi
240 w = c + z( ii )*z( ii ) / delta( ii ) +
241 $ z( n )*z( n ) / delta( n )
242*
243 IF( w.LE.zero ) THEN
244 temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) +
245 $ z( n )*z( n ) / rho
246 IF( c.LE.temp ) THEN
247 tau = rho
248 ELSE
249 del = d( n ) - d( n-1 )
250 a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
251 b = z( n )*z( n )*del
252 IF( a.LT.zero ) THEN
253 tau = two*b / ( sqrt( a*a+four*b*c )-a )
254 ELSE
255 tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
256 END IF
257 END IF
258*
259* It can be proved that
260* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
261*
262 dltlb = midpt
263 dltub = rho
264 ELSE
265 del = d( n ) - d( n-1 )
266 a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
267 b = z( n )*z( n )*del
268 IF( a.LT.zero ) THEN
269 tau = two*b / ( sqrt( a*a+four*b*c )-a )
270 ELSE
271 tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
272 END IF
273*
274* It can be proved that
275* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
276*
277 dltlb = zero
278 dltub = midpt
279 END IF
280*
281 DO 30 j = 1, n
282 delta( j ) = ( d( j )-d( i ) ) - tau
283 30 CONTINUE
284*
285* Evaluate PSI and the derivative DPSI
286*
287 dpsi = zero
288 psi = zero
289 erretm = zero
290 DO 40 j = 1, ii
291 temp = z( j ) / delta( j )
292 psi = psi + z( j )*temp
293 dpsi = dpsi + temp*temp
294 erretm = erretm + psi
295 40 CONTINUE
296 erretm = abs( erretm )
297*
298* Evaluate PHI and the derivative DPHI
299*
300 temp = z( n ) / delta( n )
301 phi = z( n )*temp
302 dphi = temp*temp
303 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
304 $ abs( tau )*( dpsi+dphi )
305*
306 w = rhoinv + phi + psi
307*
308* Test for convergence
309*
310 IF( abs( w ).LE.eps*erretm ) THEN
311 dlam = d( i ) + tau
312 GO TO 250
313 END IF
314*
315 IF( w.LE.zero ) THEN
316 dltlb = max( dltlb, tau )
317 ELSE
318 dltub = min( dltub, tau )
319 END IF
320*
321* Calculate the new step
322*
323 niter = niter + 1
324 c = w - delta( n-1 )*dpsi - delta( n )*dphi
325 a = ( delta( n-1 )+delta( n ) )*w -
326 $ delta( n-1 )*delta( n )*( dpsi+dphi )
327 b = delta( n-1 )*delta( n )*w
328 IF( c.LT.zero )
329 $ c = abs( c )
330 IF( c.EQ.zero ) THEN
331* ETA = B/A
332* ETA = RHO - TAU
333 eta = dltub - tau
334 ELSE IF( a.GE.zero ) THEN
335 eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
336 ELSE
337 eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
338 END IF
339*
340* Note, eta should be positive if w is negative, and
341* eta should be negative otherwise. However,
342* if for some reason caused by roundoff, eta*w > 0,
343* we simply use one Newton step instead. This way
344* will guarantee eta*w < 0.
345*
346 IF( w*eta.GT.zero )
347 $ eta = -w / ( dpsi+dphi )
348 temp = tau + eta
349 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
350 IF( w.LT.zero ) THEN
351 eta = ( dltub-tau ) / two
352 ELSE
353 eta = ( dltlb-tau ) / two
354 END IF
355 END IF
356 DO 50 j = 1, n
357 delta( j ) = delta( j ) - eta
358 50 CONTINUE
359*
360 tau = tau + eta
361*
362* Evaluate PSI and the derivative DPSI
363*
364 dpsi = zero
365 psi = zero
366 erretm = zero
367 DO 60 j = 1, ii
368 temp = z( j ) / delta( j )
369 psi = psi + z( j )*temp
370 dpsi = dpsi + temp*temp
371 erretm = erretm + psi
372 60 CONTINUE
373 erretm = abs( erretm )
374*
375* Evaluate PHI and the derivative DPHI
376*
377 temp = z( n ) / delta( n )
378 phi = z( n )*temp
379 dphi = temp*temp
380 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
381 $ abs( tau )*( dpsi+dphi )
382*
383 w = rhoinv + phi + psi
384*
385* Main loop to update the values of the array DELTA
386*
387 iter = niter + 1
388*
389 DO 90 niter = iter, maxit
390*
391* Test for convergence
392*
393 IF( abs( w ).LE.eps*erretm ) THEN
394 dlam = d( i ) + tau
395 GO TO 250
396 END IF
397*
398 IF( w.LE.zero ) THEN
399 dltlb = max( dltlb, tau )
400 ELSE
401 dltub = min( dltub, tau )
402 END IF
403*
404* Calculate the new step
405*
406 c = w - delta( n-1 )*dpsi - delta( n )*dphi
407 a = ( delta( n-1 )+delta( n ) )*w -
408 $ delta( n-1 )*delta( n )*( dpsi+dphi )
409 b = delta( n-1 )*delta( n )*w
410 IF( a.GE.zero ) THEN
411 eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
412 ELSE
413 eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
414 END IF
415*
416* Note, eta should be positive if w is negative, and
417* eta should be negative otherwise. However,
418* if for some reason caused by roundoff, eta*w > 0,
419* we simply use one Newton step instead. This way
420* will guarantee eta*w < 0.
421*
422 IF( w*eta.GT.zero )
423 $ eta = -w / ( dpsi+dphi )
424 temp = tau + eta
425 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
426 IF( w.LT.zero ) THEN
427 eta = ( dltub-tau ) / two
428 ELSE
429 eta = ( dltlb-tau ) / two
430 END IF
431 END IF
432 DO 70 j = 1, n
433 delta( j ) = delta( j ) - eta
434 70 CONTINUE
435*
436 tau = tau + eta
437*
438* Evaluate PSI and the derivative DPSI
439*
440 dpsi = zero
441 psi = zero
442 erretm = zero
443 DO 80 j = 1, ii
444 temp = z( j ) / delta( j )
445 psi = psi + z( j )*temp
446 dpsi = dpsi + temp*temp
447 erretm = erretm + psi
448 80 CONTINUE
449 erretm = abs( erretm )
450*
451* Evaluate PHI and the derivative DPHI
452*
453 temp = z( n ) / delta( n )
454 phi = z( n )*temp
455 dphi = temp*temp
456 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
457 $ abs( tau )*( dpsi+dphi )
458*
459 w = rhoinv + phi + psi
460 90 CONTINUE
461*
462* Return with INFO = 1, NITER = MAXIT and not converged
463*
464 info = 1
465 dlam = d( i ) + tau
466 GO TO 250
467*
468* End for the case I = N
469*
470 ELSE
471*
472* The case for I < N
473*
474 niter = 1
475 ip1 = i + 1
476*
477* Calculate initial guess
478*
479 del = d( ip1 ) - d( i )
480 midpt = del / two
481 DO 100 j = 1, n
482 delta( j ) = ( d( j )-d( i ) ) - midpt
483 100 CONTINUE
484*
485 psi = zero
486 DO 110 j = 1, i - 1
487 psi = psi + z( j )*z( j ) / delta( j )
488 110 CONTINUE
489*
490 phi = zero
491 DO 120 j = n, i + 2, -1
492 phi = phi + z( j )*z( j ) / delta( j )
493 120 CONTINUE
494 c = rhoinv + psi + phi
495 w = c + z( i )*z( i ) / delta( i ) +
496 $ z( ip1 )*z( ip1 ) / delta( ip1 )
497*
498 IF( w.GT.zero ) THEN
499*
500* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
501*
502* We choose d(i) as origin.
503*
504 orgati = .true.
505 a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 )
506 b = z( i )*z( i )*del
507 IF( a.GT.zero ) THEN
508 tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
509 ELSE
510 tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
511 END IF
512 dltlb = zero
513 dltub = midpt
514 ELSE
515*
516* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
517*
518* We choose d(i+1) as origin.
519*
520 orgati = .false.
521 a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 )
522 b = z( ip1 )*z( ip1 )*del
523 IF( a.LT.zero ) THEN
524 tau = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
525 ELSE
526 tau = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
527 END IF
528 dltlb = -midpt
529 dltub = zero
530 END IF
531*
532 IF( orgati ) THEN
533 DO 130 j = 1, n
534 delta( j ) = ( d( j )-d( i ) ) - tau
535 130 CONTINUE
536 ELSE
537 DO 140 j = 1, n
538 delta( j ) = ( d( j )-d( ip1 ) ) - tau
539 140 CONTINUE
540 END IF
541 IF( orgati ) THEN
542 ii = i
543 ELSE
544 ii = i + 1
545 END IF
546 iim1 = ii - 1
547 iip1 = ii + 1
548*
549* Evaluate PSI and the derivative DPSI
550*
551 dpsi = zero
552 psi = zero
553 erretm = zero
554 DO 150 j = 1, iim1
555 temp = z( j ) / delta( j )
556 psi = psi + z( j )*temp
557 dpsi = dpsi + temp*temp
558 erretm = erretm + psi
559 150 CONTINUE
560 erretm = abs( erretm )
561*
562* Evaluate PHI and the derivative DPHI
563*
564 dphi = zero
565 phi = zero
566 DO 160 j = n, iip1, -1
567 temp = z( j ) / delta( j )
568 phi = phi + z( j )*temp
569 dphi = dphi + temp*temp
570 erretm = erretm + phi
571 160 CONTINUE
572*
573 w = rhoinv + phi + psi
574*
575* W is the value of the secular function with
576* its ii-th element removed.
577*
578 swtch3 = .false.
579 IF( orgati ) THEN
580 IF( w.LT.zero )
581 $ swtch3 = .true.
582 ELSE
583 IF( w.GT.zero )
584 $ swtch3 = .true.
585 END IF
586 IF( ii.EQ.1 .OR. ii.EQ.n )
587 $ swtch3 = .false.
588*
589 temp = z( ii ) / delta( ii )
590 dw = dpsi + dphi + temp*temp
591 temp = z( ii )*temp
592 w = w + temp
593 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
594 $ three*abs( temp ) + abs( tau )*dw
595*
596* Test for convergence
597*
598 IF( abs( w ).LE.eps*erretm ) THEN
599 IF( orgati ) THEN
600 dlam = d( i ) + tau
601 ELSE
602 dlam = d( ip1 ) + tau
603 END IF
604 GO TO 250
605 END IF
606*
607 IF( w.LE.zero ) THEN
608 dltlb = max( dltlb, tau )
609 ELSE
610 dltub = min( dltub, tau )
611 END IF
612*
613* Calculate the new step
614*
615 niter = niter + 1
616 IF( .NOT.swtch3 ) THEN
617 IF( orgati ) THEN
618 c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*
619 $ ( z( i ) / delta( i ) )**2
620 ELSE
621 c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*
622 $ ( z( ip1 ) / delta( ip1 ) )**2
623 END IF
624 a = ( delta( i )+delta( ip1 ) )*w -
625 $ delta( i )*delta( ip1 )*dw
626 b = delta( i )*delta( ip1 )*w
627 IF( c.EQ.zero ) THEN
628 IF( a.EQ.zero ) THEN
629 IF( orgati ) THEN
630 a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*
631 $ ( dpsi+dphi )
632 ELSE
633 a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*
634 $ ( dpsi+dphi )
635 END IF
636 END IF
637 eta = b / a
638 ELSE IF( a.LE.zero ) THEN
639 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
640 ELSE
641 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
642 END IF
643 ELSE
644*
645* Interpolation using THREE most relevant poles
646*
647 temp = rhoinv + psi + phi
648 IF( orgati ) THEN
649 temp1 = z( iim1 ) / delta( iim1 )
650 temp1 = temp1*temp1
651 c = temp - delta( iip1 )*( dpsi+dphi ) -
652 $ ( d( iim1 )-d( iip1 ) )*temp1
653 zz( 1 ) = z( iim1 )*z( iim1 )
654 zz( 3 ) = delta( iip1 )*delta( iip1 )*
655 $ ( ( dpsi-temp1 )+dphi )
656 ELSE
657 temp1 = z( iip1 ) / delta( iip1 )
658 temp1 = temp1*temp1
659 c = temp - delta( iim1 )*( dpsi+dphi ) -
660 $ ( d( iip1 )-d( iim1 ) )*temp1
661 zz( 1 ) = delta( iim1 )*delta( iim1 )*
662 $ ( dpsi+( dphi-temp1 ) )
663 zz( 3 ) = z( iip1 )*z( iip1 )
664 END IF
665 zz( 2 ) = z( ii )*z( ii )
666 CALL dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,
667 $ info )
668 IF( info.NE.0 )
669 $ GO TO 250
670 END IF
671*
672* Note, eta should be positive if w is negative, and
673* eta should be negative otherwise. However,
674* if for some reason caused by roundoff, eta*w > 0,
675* we simply use one Newton step instead. This way
676* will guarantee eta*w < 0.
677*
678 IF( w*eta.GE.zero )
679 $ eta = -w / dw
680 temp = tau + eta
681 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
682 IF( w.LT.zero ) THEN
683 eta = ( dltub-tau ) / two
684 ELSE
685 eta = ( dltlb-tau ) / two
686 END IF
687 END IF
688*
689 prew = w
690*
691 DO 180 j = 1, n
692 delta( j ) = delta( j ) - eta
693 180 CONTINUE
694*
695* Evaluate PSI and the derivative DPSI
696*
697 dpsi = zero
698 psi = zero
699 erretm = zero
700 DO 190 j = 1, iim1
701 temp = z( j ) / delta( j )
702 psi = psi + z( j )*temp
703 dpsi = dpsi + temp*temp
704 erretm = erretm + psi
705 190 CONTINUE
706 erretm = abs( erretm )
707*
708* Evaluate PHI and the derivative DPHI
709*
710 dphi = zero
711 phi = zero
712 DO 200 j = n, iip1, -1
713 temp = z( j ) / delta( j )
714 phi = phi + z( j )*temp
715 dphi = dphi + temp*temp
716 erretm = erretm + phi
717 200 CONTINUE
718*
719 temp = z( ii ) / delta( ii )
720 dw = dpsi + dphi + temp*temp
721 temp = z( ii )*temp
722 w = rhoinv + phi + psi + temp
723 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
724 $ three*abs( temp ) + abs( tau+eta )*dw
725*
726 swtch = .false.
727 IF( orgati ) THEN
728 IF( -w.GT.abs( prew ) / ten )
729 $ swtch = .true.
730 ELSE
731 IF( w.GT.abs( prew ) / ten )
732 $ swtch = .true.
733 END IF
734*
735 tau = tau + eta
736*
737* Main loop to update the values of the array DELTA
738*
739 iter = niter + 1
740*
741 DO 240 niter = iter, maxit
742*
743* Test for convergence
744*
745 IF( abs( w ).LE.eps*erretm ) THEN
746 IF( orgati ) THEN
747 dlam = d( i ) + tau
748 ELSE
749 dlam = d( ip1 ) + tau
750 END IF
751 GO TO 250
752 END IF
753*
754 IF( w.LE.zero ) THEN
755 dltlb = max( dltlb, tau )
756 ELSE
757 dltub = min( dltub, tau )
758 END IF
759*
760* Calculate the new step
761*
762 IF( .NOT.swtch3 ) THEN
763 IF( .NOT.swtch ) THEN
764 IF( orgati ) THEN
765 c = w - delta( ip1 )*dw -
766 $ ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )**2
767 ELSE
768 c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*
769 $ ( z( ip1 ) / delta( ip1 ) )**2
770 END IF
771 ELSE
772 temp = z( ii ) / delta( ii )
773 IF( orgati ) THEN
774 dpsi = dpsi + temp*temp
775 ELSE
776 dphi = dphi + temp*temp
777 END IF
778 c = w - delta( i )*dpsi - delta( ip1 )*dphi
779 END IF
780 a = ( delta( i )+delta( ip1 ) )*w -
781 $ delta( i )*delta( ip1 )*dw
782 b = delta( i )*delta( ip1 )*w
783 IF( c.EQ.zero ) THEN
784 IF( a.EQ.zero ) THEN
785 IF( .NOT.swtch ) THEN
786 IF( orgati ) THEN
787 a = z( i )*z( i ) + delta( ip1 )*
788 $ delta( ip1 )*( dpsi+dphi )
789 ELSE
790 a = z( ip1 )*z( ip1 ) +
791 $ delta( i )*delta( i )*( dpsi+dphi )
792 END IF
793 ELSE
794 a = delta( i )*delta( i )*dpsi +
795 $ delta( ip1 )*delta( ip1 )*dphi
796 END IF
797 END IF
798 eta = b / a
799 ELSE IF( a.LE.zero ) THEN
800 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
801 ELSE
802 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
803 END IF
804 ELSE
805*
806* Interpolation using THREE most relevant poles
807*
808 temp = rhoinv + psi + phi
809 IF( swtch ) THEN
810 c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi
811 zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi
812 zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi
813 ELSE
814 IF( orgati ) THEN
815 temp1 = z( iim1 ) / delta( iim1 )
816 temp1 = temp1*temp1
817 c = temp - delta( iip1 )*( dpsi+dphi ) -
818 $ ( d( iim1 )-d( iip1 ) )*temp1
819 zz( 1 ) = z( iim1 )*z( iim1 )
820 zz( 3 ) = delta( iip1 )*delta( iip1 )*
821 $ ( ( dpsi-temp1 )+dphi )
822 ELSE
823 temp1 = z( iip1 ) / delta( iip1 )
824 temp1 = temp1*temp1
825 c = temp - delta( iim1 )*( dpsi+dphi ) -
826 $ ( d( iip1 )-d( iim1 ) )*temp1
827 zz( 1 ) = delta( iim1 )*delta( iim1 )*
828 $ ( dpsi+( dphi-temp1 ) )
829 zz( 3 ) = z( iip1 )*z( iip1 )
830 END IF
831 END IF
832 CALL dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,
833 $ info )
834 IF( info.NE.0 )
835 $ GO TO 250
836 END IF
837*
838* Note, eta should be positive if w is negative, and
839* eta should be negative otherwise. However,
840* if for some reason caused by roundoff, eta*w > 0,
841* we simply use one Newton step instead. This way
842* will guarantee eta*w < 0.
843*
844 IF( w*eta.GE.zero )
845 $ eta = -w / dw
846 temp = tau + eta
847 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
848 IF( w.LT.zero ) THEN
849 eta = ( dltub-tau ) / two
850 ELSE
851 eta = ( dltlb-tau ) / two
852 END IF
853 END IF
854*
855 DO 210 j = 1, n
856 delta( j ) = delta( j ) - eta
857 210 CONTINUE
858*
859 tau = tau + eta
860 prew = w
861*
862* Evaluate PSI and the derivative DPSI
863*
864 dpsi = zero
865 psi = zero
866 erretm = zero
867 DO 220 j = 1, iim1
868 temp = z( j ) / delta( j )
869 psi = psi + z( j )*temp
870 dpsi = dpsi + temp*temp
871 erretm = erretm + psi
872 220 CONTINUE
873 erretm = abs( erretm )
874*
875* Evaluate PHI and the derivative DPHI
876*
877 dphi = zero
878 phi = zero
879 DO 230 j = n, iip1, -1
880 temp = z( j ) / delta( j )
881 phi = phi + z( j )*temp
882 dphi = dphi + temp*temp
883 erretm = erretm + phi
884 230 CONTINUE
885*
886 temp = z( ii ) / delta( ii )
887 dw = dpsi + dphi + temp*temp
888 temp = z( ii )*temp
889 w = rhoinv + phi + psi + temp
890 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
891 $ three*abs( temp ) + abs( tau )*dw
892 IF( w*prew.GT.zero .AND. abs( w ).GT.abs( prew ) / ten )
893 $ swtch = .NOT.swtch
894*
895 240 CONTINUE
896*
897* Return with INFO = 1, NITER = MAXIT and not converged
898*
899 info = 1
900 IF( orgati ) THEN
901 dlam = d( i ) + tau
902 ELSE
903 dlam = d( ip1 ) + tau
904 END IF
905*
906 END IF
907*
908 250 CONTINUE
909*
910 RETURN
911*
912* End of DLAED4
913*
dlaed5
subroutine dlaed5(i, d, z, delta, rho, dlam)
DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation.
Definition dlaed5.f:108
dlaed6
subroutine dlaed6(kniter, orgati, rho, d, z, finit, tau, info)
DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation.
Definition dlaed6.f:140

◆ dlaed5()

subroutine dlaed5 ( integer i,
double precision, dimension( 2 ) d,
double precision, dimension( 2 ) z,
double precision, dimension( 2 ) delta,
double precision rho,
double precision dlam )

DLAED5 used by DSTEDC. Solves the 2-by-2 secular equation.

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

Purpose:
!>
!> This subroutine computes the I-th eigenvalue of a symmetric rank-one
!> modification of a 2-by-2 diagonal matrix
!>
!>            diag( D )  +  RHO * Z * transpose(Z) .
!>
!> The diagonal elements in the array D are assumed to satisfy
!>
!>            D(i) < D(j)  for  i < j .
!>
!> We also assume RHO > 0 and that the Euclidean norm of the vector
!> Z is one.
!>
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 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)
!>         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]DLAM
!>          DLAM is DOUBLE PRECISION
!>         The computed lambda_I, the I-th updated 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 107 of file dlaed5.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER I
115 DOUBLE PRECISION DLAM, RHO
116* ..
117* .. Array Arguments ..
118 DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 DOUBLE PRECISION ZERO, ONE, TWO, FOUR
125 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
126 $ four = 4.0d0 )
127* ..
128* .. Local Scalars ..
129 DOUBLE PRECISION B, C, DEL, TAU, TEMP, W
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, sqrt
133* ..
134* .. Executable Statements ..
135*
136 del = d( 2 ) - d( 1 )
137 IF( i.EQ.1 ) THEN
138 w = one + two*rho*( z( 2 )*z( 2 )-z( 1 )*z( 1 ) ) / del
139 IF( w.GT.zero ) THEN
140 b = del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
141 c = rho*z( 1 )*z( 1 )*del
142*
143* B > ZERO, always
144*
145 tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
146 dlam = d( 1 ) + tau
147 delta( 1 ) = -z( 1 ) / tau
148 delta( 2 ) = z( 2 ) / ( del-tau )
149 ELSE
150 b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
151 c = rho*z( 2 )*z( 2 )*del
152 IF( b.GT.zero ) THEN
153 tau = -two*c / ( b+sqrt( b*b+four*c ) )
154 ELSE
155 tau = ( b-sqrt( b*b+four*c ) ) / two
156 END IF
157 dlam = d( 2 ) + tau
158 delta( 1 ) = -z( 1 ) / ( del+tau )
159 delta( 2 ) = -z( 2 ) / tau
160 END IF
161 temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) )
162 delta( 1 ) = delta( 1 ) / temp
163 delta( 2 ) = delta( 2 ) / temp
164 ELSE
165*
166* Now I=2
167*
168 b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
169 c = rho*z( 2 )*z( 2 )*del
170 IF( b.GT.zero ) THEN
171 tau = ( b+sqrt( b*b+four*c ) ) / two
172 ELSE
173 tau = two*c / ( -b+sqrt( b*b+four*c ) )
174 END IF
175 dlam = d( 2 ) + tau
176 delta( 1 ) = -z( 1 ) / ( del+tau )
177 delta( 2 ) = -z( 2 ) / tau
178 temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) )
179 delta( 1 ) = delta( 1 ) / temp
180 delta( 2 ) = delta( 2 ) / temp
181 END IF
182 RETURN
183*
184* End of DLAED5
185*

◆ dlaed6()

subroutine dlaed6 ( integer kniter,
logical orgati,
double precision rho,
double precision, dimension( 3 ) d,
double precision, dimension( 3 ) z,
double precision finit,
double precision tau,
integer info )

DLAED6 used by DSTEDC. Computes one Newton step in solution of the secular equation.

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

Purpose:
!>
!> DLAED6 computes the positive or negative root (closest to the origin)
!> of
!>                  z(1)        z(2)        z(3)
!> f(x) =   rho + --------- + ---------- + ---------
!>                 d(1)-x      d(2)-x      d(3)-x
!>
!> It is assumed that
!>
!>       if ORGATI = .true. the root is between d(2) and d(3);
!>       otherwise it is between d(1) and d(2)
!>
!> This routine will be called by DLAED4 when necessary. In most cases,
!> the root sought is the smallest in magnitude, though it might not be
!> in some extremely rare situations.
!>
Parameters
[in]KNITER
!>          KNITER is INTEGER
!>               Refer to DLAED4 for its significance.
!>
[in]ORGATI
!>          ORGATI is LOGICAL
!>               If ORGATI is true, the needed root is between d(2) and
!>               d(3); otherwise it is between d(1) and d(2).  See
!>               DLAED4 for further details.
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>               Refer to the equation f(x) above.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (3)
!>               D satisfies d(1) < d(2) < d(3).
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension (3)
!>               Each of the elements in z must be positive.
!>
[in]FINIT
!>          FINIT is DOUBLE PRECISION
!>               The value of f at 0. It is more accurate than the one
!>               evaluated inside this routine (if someone wants to do
!>               so).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION
!>               The root of the equation f(x).
!>
[out]INFO
!>          INFO is INTEGER
!>               = 0: successful exit
!>               > 0: if INFO = 1, failure to converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  10/02/03: This version has a few statements commented out for thread
!>  safety (machine parameters are computed on each entry). SJH.
!>
!>  05/10/06: Modified from a new version of Ren-Cang Li, use
!>     Gragg-Thornton-Warner cubic convergent scheme for better stability.
!>
Contributors:
Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 139 of file dlaed6.f.

140*
141* -- LAPACK computational routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 LOGICAL ORGATI
147 INTEGER INFO, KNITER
148 DOUBLE PRECISION FINIT, RHO, TAU
149* ..
150* .. Array Arguments ..
151 DOUBLE PRECISION D( 3 ), Z( 3 )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 INTEGER MAXIT
158 parameter( maxit = 40 )
159 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
160 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
161 $ three = 3.0d0, four = 4.0d0, eight = 8.0d0 )
162* ..
163* .. External Functions ..
164 DOUBLE PRECISION DLAMCH
165 EXTERNAL dlamch
166* ..
167* .. Local Arrays ..
168 DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
169* ..
170* .. Local Scalars ..
171 LOGICAL SCALE
172 INTEGER I, ITER, NITER
173 DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
174 $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
175 $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
176 $ LBD, UBD
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC abs, int, log, max, min, sqrt
180* ..
181* .. Executable Statements ..
182*
183 info = 0
184*
185 IF( orgati ) THEN
186 lbd = d(2)
187 ubd = d(3)
188 ELSE
189 lbd = d(1)
190 ubd = d(2)
191 END IF
192 IF( finit .LT. zero )THEN
193 lbd = zero
194 ELSE
195 ubd = zero
196 END IF
197*
198 niter = 1
199 tau = zero
200 IF( kniter.EQ.2 ) THEN
201 IF( orgati ) THEN
202 temp = ( d( 3 )-d( 2 ) ) / two
203 c = rho + z( 1 ) / ( ( d( 1 )-d( 2 ) )-temp )
204 a = c*( d( 2 )+d( 3 ) ) + z( 2 ) + z( 3 )
205 b = c*d( 2 )*d( 3 ) + z( 2 )*d( 3 ) + z( 3 )*d( 2 )
206 ELSE
207 temp = ( d( 1 )-d( 2 ) ) / two
208 c = rho + z( 3 ) / ( ( d( 3 )-d( 2 ) )-temp )
209 a = c*( d( 1 )+d( 2 ) ) + z( 1 ) + z( 2 )
210 b = c*d( 1 )*d( 2 ) + z( 1 )*d( 2 ) + z( 2 )*d( 1 )
211 END IF
212 temp = max( abs( a ), abs( b ), abs( c ) )
213 a = a / temp
214 b = b / temp
215 c = c / temp
216 IF( c.EQ.zero ) THEN
217 tau = b / a
218 ELSE IF( a.LE.zero ) THEN
219 tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
220 ELSE
221 tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
222 END IF
223 IF( tau .LT. lbd .OR. tau .GT. ubd )
224 $ tau = ( lbd+ubd )/two
225 IF( d(1).EQ.tau .OR. d(2).EQ.tau .OR. d(3).EQ.tau ) THEN
226 tau = zero
227 ELSE
228 temp = finit + tau*z(1)/( d(1)*( d( 1 )-tau ) ) +
229 $ tau*z(2)/( d(2)*( d( 2 )-tau ) ) +
230 $ tau*z(3)/( d(3)*( d( 3 )-tau ) )
231 IF( temp .LE. zero )THEN
232 lbd = tau
233 ELSE
234 ubd = tau
235 END IF
236 IF( abs( finit ).LE.abs( temp ) )
237 $ tau = zero
238 END IF
239 END IF
240*
241* get machine parameters for possible scaling to avoid overflow
242*
243* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
244* SMINV2, EPS are not SAVEd anymore between one call to the
245* others but recomputed at each call
246*
247 eps = dlamch( 'Epsilon' )
248 base = dlamch( 'Base' )
249 small1 = base**( int( log( dlamch( 'SafMin' ) ) / log( base ) /
250 $ three ) )
251 sminv1 = one / small1
252 small2 = small1*small1
253 sminv2 = sminv1*sminv1
254*
255* Determine if scaling of inputs necessary to avoid overflow
256* when computing 1/TEMP**3
257*
258 IF( orgati ) THEN
259 temp = min( abs( d( 2 )-tau ), abs( d( 3 )-tau ) )
260 ELSE
261 temp = min( abs( d( 1 )-tau ), abs( d( 2 )-tau ) )
262 END IF
263 scale = .false.
264 IF( temp.LE.small1 ) THEN
265 scale = .true.
266 IF( temp.LE.small2 ) THEN
267*
268* Scale up by power of radix nearest 1/SAFMIN**(2/3)
269*
270 sclfac = sminv2
271 sclinv = small2
272 ELSE
273*
274* Scale up by power of radix nearest 1/SAFMIN**(1/3)
275*
276 sclfac = sminv1
277 sclinv = small1
278 END IF
279*
280* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
281*
282 DO 10 i = 1, 3
283 dscale( i ) = d( i )*sclfac
284 zscale( i ) = z( i )*sclfac
285 10 CONTINUE
286 tau = tau*sclfac
287 lbd = lbd*sclfac
288 ubd = ubd*sclfac
289 ELSE
290*
291* Copy D and Z to DSCALE and ZSCALE
292*
293 DO 20 i = 1, 3
294 dscale( i ) = d( i )
295 zscale( i ) = z( i )
296 20 CONTINUE
297 END IF
298*
299 fc = zero
300 df = zero
301 ddf = zero
302 DO 30 i = 1, 3
303 temp = one / ( dscale( i )-tau )
304 temp1 = zscale( i )*temp
305 temp2 = temp1*temp
306 temp3 = temp2*temp
307 fc = fc + temp1 / dscale( i )
308 df = df + temp2
309 ddf = ddf + temp3
310 30 CONTINUE
311 f = finit + tau*fc
312*
313 IF( abs( f ).LE.zero )
314 $ GO TO 60
315 IF( f .LE. zero )THEN
316 lbd = tau
317 ELSE
318 ubd = tau
319 END IF
320*
321* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
322* scheme
323*
324* It is not hard to see that
325*
326* 1) Iterations will go up monotonically
327* if FINIT < 0;
328*
329* 2) Iterations will go down monotonically
330* if FINIT > 0.
331*
332 iter = niter + 1
333*
334 DO 50 niter = iter, maxit
335*
336 IF( orgati ) THEN
337 temp1 = dscale( 2 ) - tau
338 temp2 = dscale( 3 ) - tau
339 ELSE
340 temp1 = dscale( 1 ) - tau
341 temp2 = dscale( 2 ) - tau
342 END IF
343 a = ( temp1+temp2 )*f - temp1*temp2*df
344 b = temp1*temp2*f
345 c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
346 temp = max( abs( a ), abs( b ), abs( c ) )
347 a = a / temp
348 b = b / temp
349 c = c / temp
350 IF( c.EQ.zero ) THEN
351 eta = b / a
352 ELSE IF( a.LE.zero ) THEN
353 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
354 ELSE
355 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
356 END IF
357 IF( f*eta.GE.zero ) THEN
358 eta = -f / df
359 END IF
360*
361 tau = tau + eta
362 IF( tau .LT. lbd .OR. tau .GT. ubd )
363 $ tau = ( lbd + ubd )/two
364*
365 fc = zero
366 erretm = zero
367 df = zero
368 ddf = zero
369 DO 40 i = 1, 3
370 IF ( ( dscale( i )-tau ).NE.zero ) THEN
371 temp = one / ( dscale( i )-tau )
372 temp1 = zscale( i )*temp
373 temp2 = temp1*temp
374 temp3 = temp2*temp
375 temp4 = temp1 / dscale( i )
376 fc = fc + temp4
377 erretm = erretm + abs( temp4 )
378 df = df + temp2
379 ddf = ddf + temp3
380 ELSE
381 GO TO 60
382 END IF
383 40 CONTINUE
384 f = finit + tau*fc
385 erretm = eight*( abs( finit )+abs( tau )*erretm ) +
386 $ abs( tau )*df
387 IF( ( abs( f ).LE.four*eps*erretm ) .OR.
388 $ ( (ubd-lbd).LE.four*eps*abs(tau) ) )
389 $ GO TO 60
390 IF( f .LE. zero )THEN
391 lbd = tau
392 ELSE
393 ubd = tau
394 END IF
395 50 CONTINUE
396 info = 1
397 60 CONTINUE
398*
399* Undo scaling
400*
401 IF( scale )
402 $ tau = tau*sclinv
403 RETURN
404*
405* End of DLAED6
406*

◆ dlaed7()

subroutine dlaed7 ( integer icompq,
integer n,
integer qsiz,
integer tlvls,
integer curlvl,
integer curpbm,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
double precision rho,
integer cutpnt,
double precision, dimension( * ) qstore,
integer, dimension( * ) qptr,
integer, dimension( * ) prmptr,
integer, dimension( * ) perm,
integer, dimension( * ) givptr,
integer, dimension( 2, * ) givcol,
double precision, dimension( 2, * ) givnum,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DLAED7 used by DSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.

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

Purpose:
!>
!> DLAED7 computes the updated eigensystem of a diagonal
!> matrix after modification by a rank-one symmetric matrix. This
!> routine is used only for the eigenproblem which requires all
!> eigenvalues and optionally eigenvectors of a dense symmetric matrix
!> that has been reduced to tridiagonal form.  DLAED1 handles
!> the case in which all eigenvalues and eigenvectors of a symmetric
!> tridiagonal matrix are desired.
!>
!>   T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!>
!>    where Z = Q**Tu, u is a vector of length N with ones in the
!>    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!>
!>    The eigenvectors of the original matrix are stored in Q, and the
!>    eigenvalues are in D.  The algorithm consists of three stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple eigenvalues or if there is a zero in
!>       the Z vector.  For each such occurrence the dimension of the
!>       secular equation problem is reduced by one.  This stage is
!>       performed by the routine DLAED8.
!>
!>       The second stage consists of calculating the updated
!>       eigenvalues. This is done by finding the roots of the secular
!>       equation via the routine DLAED4 (as called by DLAED9).
!>       This routine also calculates the eigenvectors of the current
!>       problem.
!>
!>       The final stage consists of computing the updated eigenvectors
!>       directly using the updated eigenvalues.  The eigenvectors for
!>       the current problem are multiplied with the eigenvectors from
!>       the overall problem.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in]TLVLS
!>          TLVLS is INTEGER
!>         The total number of merging levels in the overall divide and
!>         conquer tree.
!>
[in]CURLVL
!>          CURLVL is INTEGER
!>         The current level in the overall merge routine,
!>         0 <= CURLVL <= TLVLS.
!>
[in]CURPBM
!>          CURPBM is INTEGER
!>         The current problem in the current level in the overall
!>         merge routine (counting from upper left to lower right).
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the eigenvalues of the rank-1-perturbed matrix.
!>         On exit, the eigenvalues of the repaired matrix.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ, N)
!>         On entry, the eigenvectors of the rank-1-perturbed matrix.
!>         On exit, the eigenvectors of the repaired tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which will reintegrate the subproblem just
!>         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
!>         will be in ascending order.
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>         The subdiagonal element used to create the rank-1
!>         modification.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         Contains the location of the last eigenvalue in the leading
!>         sub-matrix.  min(1,N) <= CUTPNT <= N.
!>
[in,out]QSTORE
!>          QSTORE is DOUBLE PRECISION array, dimension (N**2+1)
!>         Stores eigenvectors of submatrices encountered during
!>         divide and conquer, packed together. QPTR points to
!>         beginning of the submatrices.
!>
[in,out]QPTR
!>          QPTR is INTEGER array, dimension (N+2)
!>         List of indices pointing to beginning of submatrices stored
!>         in QSTORE. The submatrices are numbered starting at the
!>         bottom left of the divide and conquer tree, from left to
!>         right and bottom to top.
!>
[in]PRMPTR
!>          PRMPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in PERM a
!>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!>         indicates the size of the permutation and also the size of
!>         the full, non-deflated problem.
!>
[in]PERM
!>          PERM is INTEGER array, dimension (N lg N)
!>         Contains the permutations (from deflation and sorting) to be
!>         applied to each eigenblock.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in GIVCOL a
!>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!>         indicates the number of Givens rotations.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N lg N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (3*N+2*QSIZ*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 256 of file dlaed7.f.

260*
261* -- LAPACK computational routine --
262* -- LAPACK is a software package provided by Univ. of Tennessee, --
263* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
264*
265* .. Scalar Arguments ..
266 INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
267 $ QSIZ, TLVLS
268 DOUBLE PRECISION RHO
269* ..
270* .. Array Arguments ..
271 INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
272 $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
273 DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
274 $ QSTORE( * ), WORK( * )
275* ..
276*
277* =====================================================================
278*
279* .. Parameters ..
280 DOUBLE PRECISION ONE, ZERO
281 parameter( one = 1.0d0, zero = 0.0d0 )
282* ..
283* .. Local Scalars ..
284 INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
285 $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
286* ..
287* .. External Subroutines ..
288 EXTERNAL dgemm, dlaed8, dlaed9, dlaeda, dlamrg, xerbla
289* ..
290* .. Intrinsic Functions ..
291 INTRINSIC max, min
292* ..
293* .. Executable Statements ..
294*
295* Test the input parameters.
296*
297 info = 0
298*
299 IF( icompq.LT.0 .OR. icompq.GT.1 ) THEN
300 info = -1
301 ELSE IF( n.LT.0 ) THEN
302 info = -2
303 ELSE IF( icompq.EQ.1 .AND. qsiz.LT.n ) THEN
304 info = -3
305 ELSE IF( ldq.LT.max( 1, n ) ) THEN
306 info = -9
307 ELSE IF( min( 1, n ).GT.cutpnt .OR. n.LT.cutpnt ) THEN
308 info = -12
309 END IF
310 IF( info.NE.0 ) THEN
311 CALL xerbla( 'DLAED7', -info )
312 RETURN
313 END IF
314*
315* Quick return if possible
316*
317 IF( n.EQ.0 )
318 $ RETURN
319*
320* The following values are for bookkeeping purposes only. They are
321* integer pointers which indicate the portion of the workspace
322* used by a particular array in DLAED8 and DLAED9.
323*
324 IF( icompq.EQ.1 ) THEN
325 ldq2 = qsiz
326 ELSE
327 ldq2 = n
328 END IF
329*
330 iz = 1
331 idlmda = iz + n
332 iw = idlmda + n
333 iq2 = iw + n
334 is = iq2 + n*ldq2
335*
336 indx = 1
337 indxc = indx + n
338 coltyp = indxc + n
339 indxp = coltyp + n
340*
341* Form the z-vector which consists of the last row of Q_1 and the
342* first row of Q_2.
343*
344 ptr = 1 + 2**tlvls
345 DO 10 i = 1, curlvl - 1
346 ptr = ptr + 2**( tlvls-i )
347 10 CONTINUE
348 curr = ptr + curpbm
349 CALL dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,
350 $ givcol, givnum, qstore, qptr, work( iz ),
351 $ work( iz+n ), info )
352*
353* When solving the final problem, we no longer need the stored data,
354* so we will overwrite the data from this level onto the previously
355* used storage space.
356*
357 IF( curlvl.EQ.tlvls ) THEN
358 qptr( curr ) = 1
359 prmptr( curr ) = 1
360 givptr( curr ) = 1
361 END IF
362*
363* Sort and Deflate eigenvalues.
364*
365 CALL dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt,
366 $ work( iz ), work( idlmda ), work( iq2 ), ldq2,
367 $ work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ),
368 $ givcol( 1, givptr( curr ) ),
369 $ givnum( 1, givptr( curr ) ), iwork( indxp ),
370 $ iwork( indx ), info )
371 prmptr( curr+1 ) = prmptr( curr ) + n
372 givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
373*
374* Solve Secular Equation.
375*
376 IF( k.NE.0 ) THEN
377 CALL dlaed9( k, 1, k, n, d, work( is ), k, rho, work( idlmda ),
378 $ work( iw ), qstore( qptr( curr ) ), k, info )
379 IF( info.NE.0 )
380 $ GO TO 30
381 IF( icompq.EQ.1 ) THEN
382 CALL dgemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2,
383 $ qstore( qptr( curr ) ), k, zero, q, ldq )
384 END IF
385 qptr( curr+1 ) = qptr( curr ) + k**2
386*
387* Prepare the INDXQ sorting permutation.
388*
389 n1 = k
390 n2 = n - k
391 CALL dlamrg( n1, n2, d, 1, -1, indxq )
392 ELSE
393 qptr( curr+1 ) = qptr( curr )
394 DO 20 i = 1, n
395 indxq( i ) = i
396 20 CONTINUE
397 END IF
398*
399 30 CONTINUE
400 RETURN
401*
402* End of DLAED7
403*
dlaed8
subroutine dlaed8(icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt, z, dlamda, q2, ldq2, w, perm, givptr, givcol, givnum, indxp, indx, info)
DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matri...
Definition dlaed8.f:243
dlaed9
subroutine dlaed9(k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, s, lds, info)
DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors....
Definition dlaed9.f:156
dlaeda
subroutine dlaeda(n, tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, info)
DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diagonal ma...
Definition dlaeda.f:166

◆ dlaed8()

subroutine dlaed8 ( integer icompq,
integer k,
integer n,
integer qsiz,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
double precision rho,
integer cutpnt,
double precision, dimension( * ) z,
double precision, dimension( * ) dlamda,
double precision, dimension( ldq2, * ) q2,
integer ldq2,
double precision, dimension( * ) w,
integer, dimension( * ) perm,
integer givptr,
integer, dimension( 2, * ) givcol,
double precision, dimension( 2, * ) givnum,
integer, dimension( * ) indxp,
integer, dimension( * ) indx,
integer info )

DLAED8 used by DSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.

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

Purpose:
!>
!> DLAED8 merges the two sets of eigenvalues together into a single
!> sorted set.  Then it tries to deflate the size of the problem.
!> There are two ways in which deflation can occur:  when two or more
!> eigenvalues are close together or if there is a tiny element in the
!> Z vector.  For each such occurrence the order of the related secular
!> equation problem is reduced by one.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>
[out]K
!>          K is INTEGER
!>         The number of non-deflated eigenvalues, and the order of the
!>         related secular equation.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>         On entry, the eigenvalues of the two submatrices to be
!>         combined.  On exit, the trailing (N-K) updated eigenvalues
!>         (those which were deflated) sorted into increasing order.
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,N)
!>         If ICOMPQ = 0, Q is not referenced.  Otherwise,
!>         on entry, Q contains the eigenvectors of the partially solved
!>         system which has been previously updated in matrix
!>         multiplies with other partially solved eigensystems.
!>         On exit, Q contains the trailing (N-K) updated eigenvectors
!>         (those which were deflated) in its last N-K columns.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which separately sorts the two sub-problems
!>         in D into ascending order.  Note that elements in the second
!>         half of this permutation must first have CUTPNT added to
!>         their values in order to be accurate.
!>
[in,out]RHO
!>          RHO is DOUBLE PRECISION
!>         On entry, the off-diagonal element associated with the rank-1
!>         cut which originally split the two submatrices which are now
!>         being recombined.
!>         On exit, RHO has been modified to the value required by
!>         DLAED3.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         The location of the last eigenvalue in the leading
!>         sub-matrix.  min(1,N) <= CUTPNT <= N.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension (N)
!>         On entry, Z contains the updating vector (the last row of
!>         the first sub-eigenvector matrix and the first row of the
!>         second sub-eigenvector matrix).
!>         On exit, the contents of Z are destroyed by the updating
!>         process.
!>
[out]DLAMDA
!>          DLAMDA is DOUBLE PRECISION array, dimension (N)
!>         A copy of the first K eigenvalues which will be used by
!>         DLAED3 to form the secular equation.
!>
[out]Q2
!>          Q2 is DOUBLE PRECISION array, dimension (LDQ2,N)
!>         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
!>         a copy of the first K eigenvectors which will be used by
!>         DLAED7 in a matrix multiply (DGEMM) to update the new
!>         eigenvectors.
!>
[in]LDQ2
!>          LDQ2 is INTEGER
!>         The leading dimension of the array Q2.  LDQ2 >= max(1,N).
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>         The first k values of the final deflation-altered z-vector and
!>         will be passed to DLAED3.
!>
[out]PERM
!>          PERM is INTEGER array, dimension (N)
!>         The permutations (from deflation and sorting) to be applied
!>         to each eigenblock.
!>
[out]GIVPTR
!>          GIVPTR is INTEGER
!>         The number of Givens rotations which took place in this
!>         subproblem.
!>
[out]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[out]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension (2, N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[out]INDXP
!>          INDXP is INTEGER array, dimension (N)
!>         The permutation used to place deflated values of D at the end
!>         of the array.  INDXP(1:K) points to the nondeflated D-values
!>         and INDXP(K+1:N) points to the deflated eigenvalues.
!>
[out]INDX
!>          INDX is INTEGER array, dimension (N)
!>         The permutation used to sort the contents of D into ascending
!>         order.
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 240 of file dlaed8.f.

243*
244* -- LAPACK computational routine --
245* -- LAPACK is a software package provided by Univ. of Tennessee, --
246* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
247*
248* .. Scalar Arguments ..
249 INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
250 $ QSIZ
251 DOUBLE PRECISION RHO
252* ..
253* .. Array Arguments ..
254 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
255 $ INDXQ( * ), PERM( * )
256 DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
257 $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
258* ..
259*
260* =====================================================================
261*
262* .. Parameters ..
263 DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
264 parameter( mone = -1.0d0, zero = 0.0d0, one = 1.0d0,
265 $ two = 2.0d0, eight = 8.0d0 )
266* ..
267* .. Local Scalars ..
268*
269 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
270 DOUBLE PRECISION C, EPS, S, T, TAU, TOL
271* ..
272* .. External Functions ..
273 INTEGER IDAMAX
274 DOUBLE PRECISION DLAMCH, DLAPY2
275 EXTERNAL idamax, dlamch, dlapy2
276* ..
277* .. External Subroutines ..
278 EXTERNAL dcopy, dlacpy, dlamrg, drot, dscal, xerbla
279* ..
280* .. Intrinsic Functions ..
281 INTRINSIC abs, max, min, sqrt
282* ..
283* .. Executable Statements ..
284*
285* Test the input parameters.
286*
287 info = 0
288*
289 IF( icompq.LT.0 .OR. icompq.GT.1 ) THEN
290 info = -1
291 ELSE IF( n.LT.0 ) THEN
292 info = -3
293 ELSE IF( icompq.EQ.1 .AND. qsiz.LT.n ) THEN
294 info = -4
295 ELSE IF( ldq.LT.max( 1, n ) ) THEN
296 info = -7
297 ELSE IF( cutpnt.LT.min( 1, n ) .OR. cutpnt.GT.n ) THEN
298 info = -10
299 ELSE IF( ldq2.LT.max( 1, n ) ) THEN
300 info = -14
301 END IF
302 IF( info.NE.0 ) THEN
303 CALL xerbla( 'DLAED8', -info )
304 RETURN
305 END IF
306*
307* Need to initialize GIVPTR to O here in case of quick exit
308* to prevent an unspecified code behavior (usually sigfault)
309* when IWORK array on entry to *stedc is not zeroed
310* (or at least some IWORK entries which used in *laed7 for GIVPTR).
311*
312 givptr = 0
313*
314* Quick return if possible
315*
316 IF( n.EQ.0 )
317 $ RETURN
318*
319 n1 = cutpnt
320 n2 = n - n1
321 n1p1 = n1 + 1
322*
323 IF( rho.LT.zero ) THEN
324 CALL dscal( n2, mone, z( n1p1 ), 1 )
325 END IF
326*
327* Normalize z so that norm(z) = 1
328*
329 t = one / sqrt( two )
330 DO 10 j = 1, n
331 indx( j ) = j
332 10 CONTINUE
333 CALL dscal( n, t, z, 1 )
334 rho = abs( two*rho )
335*
336* Sort the eigenvalues into increasing order
337*
338 DO 20 i = cutpnt + 1, n
339 indxq( i ) = indxq( i ) + cutpnt
340 20 CONTINUE
341 DO 30 i = 1, n
342 dlamda( i ) = d( indxq( i ) )
343 w( i ) = z( indxq( i ) )
344 30 CONTINUE
345 i = 1
346 j = cutpnt + 1
347 CALL dlamrg( n1, n2, dlamda, 1, 1, indx )
348 DO 40 i = 1, n
349 d( i ) = dlamda( indx( i ) )
350 z( i ) = w( indx( i ) )
351 40 CONTINUE
352*
353* Calculate the allowable deflation tolerance
354*
355 imax = idamax( n, z, 1 )
356 jmax = idamax( n, d, 1 )
357 eps = dlamch( 'Epsilon' )
358 tol = eight*eps*abs( d( jmax ) )
359*
360* If the rank-1 modifier is small enough, no more needs to be done
361* except to reorganize Q so that its columns correspond with the
362* elements in D.
363*
364 IF( rho*abs( z( imax ) ).LE.tol ) THEN
365 k = 0
366 IF( icompq.EQ.0 ) THEN
367 DO 50 j = 1, n
368 perm( j ) = indxq( indx( j ) )
369 50 CONTINUE
370 ELSE
371 DO 60 j = 1, n
372 perm( j ) = indxq( indx( j ) )
373 CALL dcopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
374 60 CONTINUE
375 CALL dlacpy( 'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ),
376 $ ldq )
377 END IF
378 RETURN
379 END IF
380*
381* If there are multiple eigenvalues then the problem deflates. Here
382* the number of equal eigenvalues are found. As each equal
383* eigenvalue is found, an elementary reflector is computed to rotate
384* the corresponding eigensubspace so that the corresponding
385* components of Z are zero in this new basis.
386*
387 k = 0
388 k2 = n + 1
389 DO 70 j = 1, n
390 IF( rho*abs( z( j ) ).LE.tol ) THEN
391*
392* Deflate due to small z component.
393*
394 k2 = k2 - 1
395 indxp( k2 ) = j
396 IF( j.EQ.n )
397 $ GO TO 110
398 ELSE
399 jlam = j
400 GO TO 80
401 END IF
402 70 CONTINUE
403 80 CONTINUE
404 j = j + 1
405 IF( j.GT.n )
406 $ GO TO 100
407 IF( rho*abs( z( j ) ).LE.tol ) THEN
408*
409* Deflate due to small z component.
410*
411 k2 = k2 - 1
412 indxp( k2 ) = j
413 ELSE
414*
415* Check if eigenvalues are close enough to allow deflation.
416*
417 s = z( jlam )
418 c = z( j )
419*
420* Find sqrt(a**2+b**2) without overflow or
421* destructive underflow.
422*
423 tau = dlapy2( c, s )
424 t = d( j ) - d( jlam )
425 c = c / tau
426 s = -s / tau
427 IF( abs( t*c*s ).LE.tol ) THEN
428*
429* Deflation is possible.
430*
431 z( j ) = tau
432 z( jlam ) = zero
433*
434* Record the appropriate Givens rotation
435*
436 givptr = givptr + 1
437 givcol( 1, givptr ) = indxq( indx( jlam ) )
438 givcol( 2, givptr ) = indxq( indx( j ) )
439 givnum( 1, givptr ) = c
440 givnum( 2, givptr ) = s
441 IF( icompq.EQ.1 ) THEN
442 CALL drot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,
443 $ q( 1, indxq( indx( j ) ) ), 1, c, s )
444 END IF
445 t = d( jlam )*c*c + d( j )*s*s
446 d( j ) = d( jlam )*s*s + d( j )*c*c
447 d( jlam ) = t
448 k2 = k2 - 1
449 i = 1
450 90 CONTINUE
451 IF( k2+i.LE.n ) THEN
452 IF( d( jlam ).LT.d( indxp( k2+i ) ) ) THEN
453 indxp( k2+i-1 ) = indxp( k2+i )
454 indxp( k2+i ) = jlam
455 i = i + 1
456 GO TO 90
457 ELSE
458 indxp( k2+i-1 ) = jlam
459 END IF
460 ELSE
461 indxp( k2+i-1 ) = jlam
462 END IF
463 jlam = j
464 ELSE
465 k = k + 1
466 w( k ) = z( jlam )
467 dlamda( k ) = d( jlam )
468 indxp( k ) = jlam
469 jlam = j
470 END IF
471 END IF
472 GO TO 80
473 100 CONTINUE
474*
475* Record the last eigenvalue.
476*
477 k = k + 1
478 w( k ) = z( jlam )
479 dlamda( k ) = d( jlam )
480 indxp( k ) = jlam
481*
482 110 CONTINUE
483*
484* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
485* and Q2 respectively. The eigenvalues/vectors which were not
486* deflated go into the first K slots of DLAMDA and Q2 respectively,
487* while those which were deflated go into the last N - K slots.
488*
489 IF( icompq.EQ.0 ) THEN
490 DO 120 j = 1, n
491 jp = indxp( j )
492 dlamda( j ) = d( jp )
493 perm( j ) = indxq( indx( jp ) )
494 120 CONTINUE
495 ELSE
496 DO 130 j = 1, n
497 jp = indxp( j )
498 dlamda( j ) = d( jp )
499 perm( j ) = indxq( indx( jp ) )
500 CALL dcopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
501 130 CONTINUE
502 END IF
503*
504* The deflated eigenvalues and their corresponding vectors go back
505* into the last N - K slots of D and Q respectively.
506*
507 IF( k.LT.n ) THEN
508 IF( icompq.EQ.0 ) THEN
509 CALL dcopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
510 ELSE
511 CALL dcopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
512 CALL dlacpy( 'A', qsiz, n-k, q2( 1, k+1 ), ldq2,
513 $ q( 1, k+1 ), ldq )
514 END IF
515 END IF
516*
517 RETURN
518*
519* End of DLAED8
520*

◆ dlaed9()

subroutine dlaed9 ( integer k,
integer kstart,
integer kstop,
integer n,
double precision, dimension( * ) d,
double precision, dimension( ldq, * ) q,
integer ldq,
double precision rho,
double precision, dimension( * ) dlamda,
double precision, dimension( * ) w,
double precision, dimension( lds, * ) s,
integer lds,
integer info )

DLAED9 used by DSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.

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

Purpose:
!>
!> DLAED9 finds the roots of the secular equation, as defined by the
!> values in D, Z, and RHO, between KSTART and KSTOP.  It makes the
!> appropriate calls to DLAED4 and then stores the new matrix of
!> eigenvectors for use in calculating the next level of Z vectors.
!>
Parameters
[in]K
!>          K is INTEGER
!>          The number of terms in the rational function to be solved by
!>          DLAED4.  K >= 0.
!>
[in]KSTART
!>          KSTART is INTEGER
!>
[in]KSTOP
!>          KSTOP is INTEGER
!>          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
!>          are to be computed.  1 <= KSTART <= KSTOP <= K.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns in the Q matrix.
!>          N >= K (delation may result in N > K).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          D(I) contains the updated eigenvalues
!>          for KSTART <= I <= KSTOP.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max( 1, N ).
!>
[in]RHO
!>          RHO is DOUBLE PRECISION
!>          The value of the parameter in the rank one update equation.
!>          RHO >= 0 required.
!>
[in]DLAMDA
!>          DLAMDA 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.
!>
[in]W
!>          W is DOUBLE PRECISION array, dimension (K)
!>          The first K elements of this array contain the components
!>          of the deflation-adjusted updating vector.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (LDS, K)
!>          Will contain the eigenvectors of the repaired matrix which
!>          will be stored for subsequent Z vector calculation and
!>          multiplied by the previously accumulated eigenvectors
!>          to update the system.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of S.  LDS >= max( 1, 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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 154 of file dlaed9.f.

156*
157* -- LAPACK computational routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
163 DOUBLE PRECISION RHO
164* ..
165* .. Array Arguments ..
166 DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
167 $ W( * )
168* ..
169*
170* =====================================================================
171*
172* .. Local Scalars ..
173 INTEGER I, J
174 DOUBLE PRECISION TEMP
175* ..
176* .. External Functions ..
177 DOUBLE PRECISION DLAMC3, DNRM2
178 EXTERNAL dlamc3, dnrm2
179* ..
180* .. External Subroutines ..
181 EXTERNAL dcopy, dlaed4, xerbla
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC max, sign, sqrt
185* ..
186* .. Executable Statements ..
187*
188* Test the input parameters.
189*
190 info = 0
191*
192 IF( k.LT.0 ) THEN
193 info = -1
194 ELSE IF( kstart.LT.1 .OR. kstart.GT.max( 1, k ) ) THEN
195 info = -2
196 ELSE IF( max( 1, kstop ).LT.kstart .OR. kstop.GT.max( 1, k ) )
197 $ THEN
198 info = -3
199 ELSE IF( n.LT.k ) THEN
200 info = -4
201 ELSE IF( ldq.LT.max( 1, k ) ) THEN
202 info = -7
203 ELSE IF( lds.LT.max( 1, k ) ) THEN
204 info = -12
205 END IF
206 IF( info.NE.0 ) THEN
207 CALL xerbla( 'DLAED9', -info )
208 RETURN
209 END IF
210*
211* Quick return if possible
212*
213 IF( k.EQ.0 )
214 $ RETURN
215*
216* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
217* be computed with high relative accuracy (barring over/underflow).
218* This is a problem on machines without a guard digit in
219* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
220* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
221* which on any of these machines zeros out the bottommost
222* bit of DLAMDA(I) if it is 1; this makes the subsequent
223* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
224* occurs. On binary machines with a guard digit (almost all
225* machines) it does not change DLAMDA(I) at all. On hexadecimal
226* and decimal machines with a guard digit, it slightly
227* changes the bottommost bits of DLAMDA(I). It does not account
228* for hexadecimal or decimal machines without guard digits
229* (we know of none). We use a subroutine call to compute
230* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
231* this code.
232*
233 DO 10 i = 1, n
234 dlamda( i ) = dlamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
235 10 CONTINUE
236*
237 DO 20 j = kstart, kstop
238 CALL dlaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info )
239*
240* If the zero finder fails, the computation is terminated.
241*
242 IF( info.NE.0 )
243 $ GO TO 120
244 20 CONTINUE
245*
246 IF( k.EQ.1 .OR. k.EQ.2 ) THEN
247 DO 40 i = 1, k
248 DO 30 j = 1, k
249 s( j, i ) = q( j, i )
250 30 CONTINUE
251 40 CONTINUE
252 GO TO 120
253 END IF
254*
255* Compute updated W.
256*
257 CALL dcopy( k, w, 1, s, 1 )
258*
259* Initialize W(I) = Q(I,I)
260*
261 CALL dcopy( k, q, ldq+1, w, 1 )
262 DO 70 j = 1, k
263 DO 50 i = 1, j - 1
264 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
265 50 CONTINUE
266 DO 60 i = j + 1, k
267 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
268 60 CONTINUE
269 70 CONTINUE
270 DO 80 i = 1, k
271 w( i ) = sign( sqrt( -w( i ) ), s( i, 1 ) )
272 80 CONTINUE
273*
274* Compute eigenvectors of the modified rank-1 modification.
275*
276 DO 110 j = 1, k
277 DO 90 i = 1, k
278 q( i, j ) = w( i ) / q( i, j )
279 90 CONTINUE
280 temp = dnrm2( k, q( 1, j ), 1 )
281 DO 100 i = 1, k
282 s( i, j ) = q( i, j ) / temp
283 100 CONTINUE
284 110 CONTINUE
285*
286 120 CONTINUE
287 RETURN
288*
289* End of DLAED9
290*

◆ dlaeda()

subroutine dlaeda ( integer n,
integer tlvls,
integer curlvl,
integer curpbm,
integer, dimension( * ) prmptr,
integer, dimension( * ) perm,
integer, dimension( * ) givptr,
integer, dimension( 2, * ) givcol,
double precision, dimension( 2, * ) givnum,
double precision, dimension( * ) q,
integer, dimension( * ) qptr,
double precision, dimension( * ) z,
double precision, dimension( * ) ztemp,
integer info )

DLAEDA used by DSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense.

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

Purpose:
!>
!> DLAEDA computes the Z vector corresponding to the merge step in the
!> CURLVLth step of the merge process with TLVLS steps for the CURPBMth
!> problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]TLVLS
!>          TLVLS is INTEGER
!>         The total number of merging levels in the overall divide and
!>         conquer tree.
!>
[in]CURLVL
!>          CURLVL is INTEGER
!>         The current level in the overall merge routine,
!>         0 <= curlvl <= tlvls.
!>
[in]CURPBM
!>          CURPBM is INTEGER
!>         The current problem in the current level in the overall
!>         merge routine (counting from upper left to lower right).
!>
[in]PRMPTR
!>          PRMPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in PERM a
!>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!>         indicates the size of the permutation and incidentally the
!>         size of the full, non-deflated problem.
!>
[in]PERM
!>          PERM is INTEGER array, dimension (N lg N)
!>         Contains the permutations (from deflation and sorting) to be
!>         applied to each eigenblock.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in GIVCOL a
!>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!>         indicates the number of Givens rotations.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N lg N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[in]GIVNUM
!>          GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[in]Q
!>          Q is DOUBLE PRECISION array, dimension (N**2)
!>         Contains the square eigenblocks from previous levels, the
!>         starting positions for blocks are given by QPTR.
!>
[in]QPTR
!>          QPTR is INTEGER array, dimension (N+2)
!>         Contains a list of pointers which indicate where in Q an
!>         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates
!>         the size of the block.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (N)
!>         On output this vector contains the updating vector (the last
!>         row of the first sub-eigenvector matrix and the first row of
!>         the second sub-eigenvector matrix).
!>
[out]ZTEMP
!>          ZTEMP is DOUBLE PRECISION array, dimension (N)
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 164 of file dlaeda.f.

166*
167* -- LAPACK computational routine --
168* -- LAPACK is a software package provided by Univ. of Tennessee, --
169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170*
171* .. Scalar Arguments ..
172 INTEGER CURLVL, CURPBM, INFO, N, TLVLS
173* ..
174* .. Array Arguments ..
175 INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
176 $ PRMPTR( * ), QPTR( * )
177 DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO, HALF, ONE
184 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
185* ..
186* .. Local Scalars ..
187 INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
188 $ PTR, ZPTR1
189* ..
190* .. External Subroutines ..
191 EXTERNAL dcopy, dgemv, drot, xerbla
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC dble, int, sqrt
195* ..
196* .. Executable Statements ..
197*
198* Test the input parameters.
199*
200 info = 0
201*
202 IF( n.LT.0 ) THEN
203 info = -1
204 END IF
205 IF( info.NE.0 ) THEN
206 CALL xerbla( 'DLAEDA', -info )
207 RETURN
208 END IF
209*
210* Quick return if possible
211*
212 IF( n.EQ.0 )
213 $ RETURN
214*
215* Determine location of first number in second half.
216*
217 mid = n / 2 + 1
218*
219* Gather last/first rows of appropriate eigenblocks into center of Z
220*
221 ptr = 1
222*
223* Determine location of lowest level subproblem in the full storage
224* scheme
225*
226 curr = ptr + curpbm*2**curlvl + 2**( curlvl-1 ) - 1
227*
228* Determine size of these matrices. We add HALF to the value of
229* the SQRT in case the machine underestimates one of these square
230* roots.
231*
232 bsiz1 = int( half+sqrt( dble( qptr( curr+1 )-qptr( curr ) ) ) )
233 bsiz2 = int( half+sqrt( dble( qptr( curr+2 )-qptr( curr+1 ) ) ) )
234 DO 10 k = 1, mid - bsiz1 - 1
235 z( k ) = zero
236 10 CONTINUE
237 CALL dcopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,
238 $ z( mid-bsiz1 ), 1 )
239 CALL dcopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 )
240 DO 20 k = mid + bsiz2, n
241 z( k ) = zero
242 20 CONTINUE
243*
244* Loop through remaining levels 1 -> CURLVL applying the Givens
245* rotations and permutation and then multiplying the center matrices
246* against the current Z.
247*
248 ptr = 2**tlvls + 1
249 DO 70 k = 1, curlvl - 1
250 curr = ptr + curpbm*2**( curlvl-k ) + 2**( curlvl-k-1 ) - 1
251 psiz1 = prmptr( curr+1 ) - prmptr( curr )
252 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
253 zptr1 = mid - psiz1
254*
255* Apply Givens at CURR and CURR+1
256*
257 DO 30 i = givptr( curr ), givptr( curr+1 ) - 1
258 CALL drot( 1, z( zptr1+givcol( 1, i )-1 ), 1,
259 $ z( zptr1+givcol( 2, i )-1 ), 1, givnum( 1, i ),
260 $ givnum( 2, i ) )
261 30 CONTINUE
262 DO 40 i = givptr( curr+1 ), givptr( curr+2 ) - 1
263 CALL drot( 1, z( mid-1+givcol( 1, i ) ), 1,
264 $ z( mid-1+givcol( 2, i ) ), 1, givnum( 1, i ),
265 $ givnum( 2, i ) )
266 40 CONTINUE
267 psiz1 = prmptr( curr+1 ) - prmptr( curr )
268 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
269 DO 50 i = 0, psiz1 - 1
270 ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1 )
271 50 CONTINUE
272 DO 60 i = 0, psiz2 - 1
273 ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1 )
274 60 CONTINUE
275*
276* Multiply Blocks at CURR and CURR+1
277*
278* Determine size of these matrices. We add HALF to the value of
279* the SQRT in case the machine underestimates one of these
280* square roots.
281*
282 bsiz1 = int( half+sqrt( dble( qptr( curr+1 )-qptr( curr ) ) ) )
283 bsiz2 = int( half+sqrt( dble( qptr( curr+2 )-qptr( curr+
284 $ 1 ) ) ) )
285 IF( bsiz1.GT.0 ) THEN
286 CALL dgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),
287 $ bsiz1, ztemp( 1 ), 1, zero, z( zptr1 ), 1 )
288 END IF
289 CALL dcopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),
290 $ 1 )
291 IF( bsiz2.GT.0 ) THEN
292 CALL dgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),
293 $ bsiz2, ztemp( psiz1+1 ), 1, zero, z( mid ), 1 )
294 END IF
295 CALL dcopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,
296 $ z( mid+bsiz2 ), 1 )
297*
298 ptr = ptr + 2**( tlvls-k )
299 70 CONTINUE
300*
301 RETURN
302*
303* End of DLAEDA
304*
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156

◆ dlagtf()

subroutine dlagtf ( integer n,
double precision, dimension( * ) a,
double precision lambda,
double precision, dimension( * ) b,
double precision, dimension( * ) c,
double precision tol,
double precision, dimension( * ) d,
integer, dimension( * ) in,
integer info )

DLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.

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

Purpose:
!>
!> DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
!> tridiagonal matrix and lambda is a scalar, as
!>
!>    T - lambda*I = PLU,
!>
!> where P is a permutation matrix, L is a unit lower tridiagonal matrix
!> with at most one non-zero sub-diagonal elements per column and U is
!> an upper triangular matrix with at most two non-zero super-diagonal
!> elements per column.
!>
!> The factorization is obtained by Gaussian elimination with partial
!> pivoting and implicit row scaling.
!>
!> The parameter LAMBDA is included in the routine so that DLAGTF may
!> be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
!> inverse iteration.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix T.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (N)
!>          On entry, A must contain the diagonal elements of T.
!>
!>          On exit, A is overwritten by the n diagonal elements of the
!>          upper triangular matrix U of the factorization of T.
!>
[in]LAMBDA
!>          LAMBDA is DOUBLE PRECISION
!>          On entry, the scalar lambda.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, B must contain the (n-1) super-diagonal elements of
!>          T.
!>
!>          On exit, B is overwritten by the (n-1) super-diagonal
!>          elements of the matrix U of the factorization of T.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, C must contain the (n-1) sub-diagonal elements of
!>          T.
!>
!>          On exit, C is overwritten by the (n-1) sub-diagonal elements
!>          of the matrix L of the factorization of T.
!>
[in]TOL
!>          TOL is DOUBLE PRECISION
!>          On entry, a relative tolerance used to indicate whether or
!>          not the matrix (T - lambda*I) is nearly singular. TOL should
!>          normally be chose as approximately the largest relative error
!>          in the elements of T. For example, if the elements of T are
!>          correct to about 4 significant figures, then TOL should be
!>          set to about 5*10**(-4). If TOL is supplied as less than eps,
!>          where eps is the relative machine precision, then the value
!>          eps is used in place of TOL.
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (N-2)
!>          On exit, D is overwritten by the (n-2) second super-diagonal
!>          elements of the matrix U of the factorization of T.
!>
[out]IN
!>          IN is INTEGER array, dimension (N)
!>          On exit, IN contains details of the permutation matrix P. If
!>          an interchange occurred at the kth step of the elimination,
!>          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
!>          returns the smallest positive integer j such that
!>
!>             abs( u(j,j) ) <= norm( (T - lambda*I)(j) )*TOL,
!>
!>          where norm( A(j) ) denotes the sum of the absolute values of
!>          the jth row of the matrix A. If no such j exists then IN(n)
!>          is returned as zero. If IN(n) is returned as positive, then a
!>          diagonal element of U is small, indicating that
!>          (T - lambda*I) is singular or nearly singular,
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the kth argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file dlagtf.f.

156*
157* -- LAPACK computational routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER INFO, N
163 DOUBLE PRECISION LAMBDA, TOL
164* ..
165* .. Array Arguments ..
166 INTEGER IN( * )
167 DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 DOUBLE PRECISION ZERO
174 parameter( zero = 0.0d+0 )
175* ..
176* .. Local Scalars ..
177 INTEGER K
178 DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, max
182* ..
183* .. External Functions ..
184 DOUBLE PRECISION DLAMCH
185 EXTERNAL dlamch
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla
189* ..
190* .. Executable Statements ..
191*
192 info = 0
193 IF( n.LT.0 ) THEN
194 info = -1
195 CALL xerbla( 'DLAGTF', -info )
196 RETURN
197 END IF
198*
199 IF( n.EQ.0 )
200 $ RETURN
201*
202 a( 1 ) = a( 1 ) - lambda
203 in( n ) = 0
204 IF( n.EQ.1 ) THEN
205 IF( a( 1 ).EQ.zero )
206 $ in( 1 ) = 1
207 RETURN
208 END IF
209*
210 eps = dlamch( 'Epsilon' )
211*
212 tl = max( tol, eps )
213 scale1 = abs( a( 1 ) ) + abs( b( 1 ) )
214 DO 10 k = 1, n - 1
215 a( k+1 ) = a( k+1 ) - lambda
216 scale2 = abs( c( k ) ) + abs( a( k+1 ) )
217 IF( k.LT.( n-1 ) )
218 $ scale2 = scale2 + abs( b( k+1 ) )
219 IF( a( k ).EQ.zero ) THEN
220 piv1 = zero
221 ELSE
222 piv1 = abs( a( k ) ) / scale1
223 END IF
224 IF( c( k ).EQ.zero ) THEN
225 in( k ) = 0
226 piv2 = zero
227 scale1 = scale2
228 IF( k.LT.( n-1 ) )
229 $ d( k ) = zero
230 ELSE
231 piv2 = abs( c( k ) ) / scale2
232 IF( piv2.LE.piv1 ) THEN
233 in( k ) = 0
234 scale1 = scale2
235 c( k ) = c( k ) / a( k )
236 a( k+1 ) = a( k+1 ) - c( k )*b( k )
237 IF( k.LT.( n-1 ) )
238 $ d( k ) = zero
239 ELSE
240 in( k ) = 1
241 mult = a( k ) / c( k )
242 a( k ) = c( k )
243 temp = a( k+1 )
244 a( k+1 ) = b( k ) - mult*temp
245 IF( k.LT.( n-1 ) ) THEN
246 d( k ) = b( k+1 )
247 b( k+1 ) = -mult*d( k )
248 END IF
249 b( k ) = temp
250 c( k ) = mult
251 END IF
252 END IF
253 IF( ( max( piv1, piv2 ).LE.tl ) .AND. ( in( n ).EQ.0 ) )
254 $ in( n ) = k
255 10 CONTINUE
256 IF( ( abs( a( n ) ).LE.scale1*tl ) .AND. ( in( n ).EQ.0 ) )
257 $ in( n ) = n
258*
259 RETURN
260*
261* End of DLAGTF
262*

◆ dlamrg()

subroutine dlamrg ( integer n1,
integer n2,
double precision, dimension( * ) a,
integer dtrd1,
integer dtrd2,
integer, dimension( * ) index )

DLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.

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

Purpose:
!>
!> DLAMRG will create a permutation list which will merge the elements
!> of A (which is composed of two independently sorted sets) into a
!> single set which is sorted in ascending order.
!>
Parameters
[in]N1
!>          N1 is INTEGER
!>
[in]N2
!>          N2 is INTEGER
!>         These arguments contain the respective lengths of the two
!>         sorted lists to be merged.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (N1+N2)
!>         The first N1 elements of A contain a list of numbers which
!>         are sorted in either ascending or descending order.  Likewise
!>         for the final N2 elements.
!>
[in]DTRD1
!>          DTRD1 is INTEGER
!>
[in]DTRD2
!>          DTRD2 is INTEGER
!>         These are the strides to be taken through the array A.
!>         Allowable strides are 1 and -1.  They indicate whether a
!>         subset of A is sorted in ascending (DTRDx = 1) or descending
!>         (DTRDx = -1) order.
!>
[out]INDEX
!>          INDEX is INTEGER array, dimension (N1+N2)
!>         On exit this array will contain a permutation such that
!>         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
!>         sorted in ascending order.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 98 of file dlamrg.f.

99*
100* -- LAPACK computational routine --
101* -- LAPACK is a software package provided by Univ. of Tennessee, --
102* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*
104* .. Scalar Arguments ..
105 INTEGER DTRD1, DTRD2, N1, N2
106* ..
107* .. Array Arguments ..
108 INTEGER INDEX( * )
109 DOUBLE PRECISION A( * )
110* ..
111*
112* =====================================================================
113*
114* .. Local Scalars ..
115 INTEGER I, IND1, IND2, N1SV, N2SV
116* ..
117* .. Executable Statements ..
118*
119 n1sv = n1
120 n2sv = n2
121 IF( dtrd1.GT.0 ) THEN
122 ind1 = 1
123 ELSE
124 ind1 = n1
125 END IF
126 IF( dtrd2.GT.0 ) THEN
127 ind2 = 1 + n1
128 ELSE
129 ind2 = n1 + n2
130 END IF
131 i = 1
132* while ( (N1SV > 0) & (N2SV > 0) )
133 10 CONTINUE
134 IF( n1sv.GT.0 .AND. n2sv.GT.0 ) THEN
135 IF( a( ind1 ).LE.a( ind2 ) ) THEN
136 index( i ) = ind1
137 i = i + 1
138 ind1 = ind1 + dtrd1
139 n1sv = n1sv - 1
140 ELSE
141 index( i ) = ind2
142 i = i + 1
143 ind2 = ind2 + dtrd2
144 n2sv = n2sv - 1
145 END IF
146 GO TO 10
147 END IF
148* end while
149 IF( n1sv.EQ.0 ) THEN
150 DO 20 n1sv = 1, n2sv
151 index( i ) = ind2
152 i = i + 1
153 ind2 = ind2 + dtrd2
154 20 CONTINUE
155 ELSE
156* N2SV .EQ. 0
157 DO 30 n2sv = 1, n1sv
158 index( i ) = ind1
159 i = i + 1
160 ind1 = ind1 + dtrd1
161 30 CONTINUE
162 END IF
163*
164 RETURN
165*
166* End of DLAMRG
167*

◆ dlartgs()

subroutine dlartgs ( double precision x,
double precision y,
double precision sigma,
double precision cs,
double precision sn )

DLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.

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

Purpose:
!>
!> DLARTGS generates a plane rotation designed to introduce a bulge in
!> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
!> problem. X and Y are the top-row entries, and SIGMA is the shift.
!> The computed CS and SN define a plane rotation satisfying
!>
!>    [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],
!>    [ -SN  CS  ]     [    X * Y    ]     [ 0 ]
!>
!> with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the
!> rotation is by PI/2.
!>
Parameters
[in]X
!>          X is DOUBLE PRECISION
!>          The (1,1) entry of an upper bidiagonal matrix.
!>
[in]Y
!>          Y is DOUBLE PRECISION
!>          The (1,2) entry of an upper bidiagonal matrix.
!>
[in]SIGMA
!>          SIGMA is DOUBLE PRECISION
!>          The shift.
!>
[out]CS
!>          CS is DOUBLE PRECISION
!>          The cosine of the rotation.
!>
[out]SN
!>          SN is DOUBLE PRECISION
!>          The sine of the rotation.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 89 of file dlartgs.f.

90*
91* -- LAPACK computational routine --
92* -- LAPACK is a software package provided by Univ. of Tennessee, --
93* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94*
95* .. Scalar Arguments ..
96 DOUBLE PRECISION CS, SIGMA, SN, X, Y
97* ..
98*
99* ===================================================================
100*
101* .. Parameters ..
102 DOUBLE PRECISION NEGONE, ONE, ZERO
103 parameter( negone = -1.0d0, one = 1.0d0, zero = 0.0d0 )
104* ..
105* .. Local Scalars ..
106 DOUBLE PRECISION R, S, THRESH, W, Z
107* ..
108* .. External Subroutines ..
109 EXTERNAL dlartgp
110* ..
111* .. External Functions ..
112 DOUBLE PRECISION DLAMCH
113 EXTERNAL dlamch
114* .. Executable Statements ..
115*
116 thresh = dlamch('E')
117*
118* Compute the first column of B**T*B - SIGMA^2*I, up to a scale
119* factor.
120*
121 IF( (sigma .EQ. zero .AND. abs(x) .LT. thresh) .OR.
122 $ (abs(x) .EQ. sigma .AND. y .EQ. zero) ) THEN
123 z = zero
124 w = zero
125 ELSE IF( sigma .EQ. zero ) THEN
126 IF( x .GE. zero ) THEN
127 z = x
128 w = y
129 ELSE
130 z = -x
131 w = -y
132 END IF
133 ELSE IF( abs(x) .LT. thresh ) THEN
134 z = -sigma*sigma
135 w = zero
136 ELSE
137 IF( x .GE. zero ) THEN
138 s = one
139 ELSE
140 s = negone
141 END IF
142 z = s * (abs(x)-sigma) * (s+sigma/x)
143 w = s * y
144 END IF
145*
146* Generate the rotation.
147* CALL DLARTGP( Z, W, CS, SN, R ) might seem more natural;
148* reordering the arguments ensures that if Z = 0 then the rotation
149* is by PI/2.
150*
151 CALL dlartgp( w, z, sn, cs, r )
152*
153 RETURN
154*
155* End DLARTGS
156*
dlartgp
subroutine dlartgp(f, g, cs, sn, r)
DLARTGP generates a plane rotation so that the diagonal is nonnegative.
Definition dlartgp.f:95

◆ dlasq1()

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

DLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.

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

Purpose:
!>
!> DLASQ1 computes the singular values of a real N-by-N bidiagonal
!> matrix with diagonal D and off-diagonal E. The singular values
!> are computed to high relative accuracy, in the absence of
!> denormalization, underflow and overflow. The algorithm was first
!> presented in
!>
!>  by K. V.
!> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
!> 1994,
!>
!> and the present implementation is described in , LAPACK Working Note.
!>
Parameters
[in]N
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>        On entry, D contains the diagonal elements of the
!>        bidiagonal matrix whose SVD is desired. On normal exit,
!>        D contains the singular values in decreasing order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N)
!>        On entry, elements E(1:N-1) contain the off-diagonal elements
!>        of the bidiagonal matrix whose SVD is desired.
!>        On exit, E is overwritten.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*N)
!>
[out]INFO
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if INFO = -i, the i-th argument had an illegal value
!>        > 0: the algorithm failed
!>             = 1, a split was marked by a positive value in E
!>             = 2, current block of Z not diagonalized after 100*N
!>                  iterations (in inner while loop)  On exit D and E
!>                  represent a matrix with the same singular values
!>                  which the calling subroutine could use to finish the
!>                  computation, or even feed back into DLASQ1
!>             = 3, termination criterion of outer while loop not met
!>                  (program created more than N unreduced blocks)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dlasq1.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER INFO, N
115* ..
116* .. Array Arguments ..
117 DOUBLE PRECISION D( * ), E( * ), WORK( * )
118* ..
119*
120* =====================================================================
121*
122* .. Parameters ..
123 DOUBLE PRECISION ZERO
124 parameter( zero = 0.0d0 )
125* ..
126* .. Local Scalars ..
127 INTEGER I, IINFO
128 DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX
129* ..
130* .. External Subroutines ..
131 EXTERNAL dcopy, dlas2, dlascl, dlasq2, dlasrt, xerbla
132* ..
133* .. External Functions ..
134 DOUBLE PRECISION DLAMCH
135 EXTERNAL dlamch
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC abs, max, sqrt
139* ..
140* .. Executable Statements ..
141*
142 info = 0
143 IF( n.LT.0 ) THEN
144 info = -1
145 CALL xerbla( 'DLASQ1', -info )
146 RETURN
147 ELSE IF( n.EQ.0 ) THEN
148 RETURN
149 ELSE IF( n.EQ.1 ) THEN
150 d( 1 ) = abs( d( 1 ) )
151 RETURN
152 ELSE IF( n.EQ.2 ) THEN
153 CALL dlas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx )
154 d( 1 ) = sigmx
155 d( 2 ) = sigmn
156 RETURN
157 END IF
158*
159* Estimate the largest singular value.
160*
161 sigmx = zero
162 DO 10 i = 1, n - 1
163 d( i ) = abs( d( i ) )
164 sigmx = max( sigmx, abs( e( i ) ) )
165 10 CONTINUE
166 d( n ) = abs( d( n ) )
167*
168* Early return if SIGMX is zero (matrix is already diagonal).
169*
170 IF( sigmx.EQ.zero ) THEN
171 CALL dlasrt( 'D', n, d, iinfo )
172 RETURN
173 END IF
174*
175 DO 20 i = 1, n
176 sigmx = max( sigmx, d( i ) )
177 20 CONTINUE
178*
179* Copy D and E into WORK (in the Z format) and scale (squaring the
180* input data makes scaling by a power of the radix pointless).
181*
182 eps = dlamch( 'Precision' )
183 safmin = dlamch( 'Safe minimum' )
184 scale = sqrt( eps / safmin )
185 CALL dcopy( n, d, 1, work( 1 ), 2 )
186 CALL dcopy( n-1, e, 1, work( 2 ), 2 )
187 CALL dlascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,
188 $ iinfo )
189*
190* Compute the q's and e's.
191*
192 DO 30 i = 1, 2*n - 1
193 work( i ) = work( i )**2
194 30 CONTINUE
195 work( 2*n ) = zero
196*
197 CALL dlasq2( n, work, info )
198*
199 IF( info.EQ.0 ) THEN
200 DO 40 i = 1, n
201 d( i ) = sqrt( work( i ) )
202 40 CONTINUE
203 CALL dlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo )
204 ELSE IF( info.EQ.2 ) THEN
205*
206* Maximum number of iterations exceeded. Move data from WORK
207* into D and E so the calling subroutine can try to finish
208*
209 DO i = 1, n
210 d( i ) = sqrt( work( 2*i-1 ) )
211 e( i ) = sqrt( work( 2*i ) )
212 END DO
213 CALL dlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo )
214 CALL dlascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo )
215 END IF
216*
217 RETURN
218*
219* End of DLASQ1
220*
dlasrt
subroutine dlasrt(id, n, d, info)
DLASRT sorts numbers in increasing or decreasing order.
Definition dlasrt.f:88
dlasq2
subroutine dlasq2(n, z, info)
DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated ...
Definition dlasq2.f:112

◆ dlasq2()

subroutine dlasq2 ( integer n,
double precision, dimension( * ) z,
integer info )

DLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> DLASQ2 computes all the eigenvalues of the symmetric positive
!> definite tridiagonal matrix associated with the qd array Z to high
!> relative accuracy are computed to high relative accuracy, in the
!> absence of denormalization, underflow and overflow.
!>
!> To see the relation of Z to the tridiagonal matrix, let L be a
!> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
!> let U be an upper bidiagonal matrix with 1's above and diagonal
!> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
!> symmetric tridiagonal to which it is similar.
!>
!> Note : DLASQ2 defines a logical variable, IEEE, which is true
!> on machines which follow ieee-754 floating-point standard in their
!> handling of infinities and NaNs, and false otherwise. This variable
!> is passed to DLASQ3.
!>
Parameters
[in]N
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N )
!>        On entry Z holds the qd array. On exit, entries 1 to N hold
!>        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
!>        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
!>        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
!>        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
!>        shifts that failed.
!>
[out]INFO
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if the i-th argument is a scalar and had an illegal
!>             value, then INFO = -i, if the i-th argument is an
!>             array and the j-entry had an illegal value, then
!>             INFO = -(i*100+j)
!>        > 0: the algorithm failed
!>              = 1, a split was marked by a positive value in E
!>              = 2, current block of Z not diagonalized after 100*N
!>                   iterations (in inner while loop).  On exit Z holds
!>                   a qd array with the same eigenvalues as the given Z.
!>              = 3, termination criterion of outer while loop not met
!>                   (program created more than N unreduced blocks)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Local Variables: I0:N0 defines a current unreduced segment of Z.
!>  The shifts are accumulated in SIGMA. Iteration count is in ITER.
!>  Ping-pong is controlled by PP (alternates between 0 and 1).
!>

Definition at line 111 of file dlasq2.f.

112*
113* -- LAPACK computational routine --
114* -- LAPACK is a software package provided by Univ. of Tennessee, --
115* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
116*
117* .. Scalar Arguments ..
118 INTEGER INFO, N
119* ..
120* .. Array Arguments ..
121 DOUBLE PRECISION Z( * )
122* ..
123*
124* =====================================================================
125*
126* .. Parameters ..
127 DOUBLE PRECISION CBIAS
128 parameter( cbias = 1.50d0 )
129 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
130 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0,
131 $ two = 2.0d0, four = 4.0d0, hundrd = 100.0d0 )
132* ..
133* .. Local Scalars ..
134 LOGICAL IEEE
135 INTEGER I0, I1, I4, IINFO, IPN4, ITER, IWHILA, IWHILB,
136 $ K, KMIN, N0, N1, NBIG, NDIV, NFAIL, PP, SPLT,
137 $ TTYPE
138 DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN,
139 $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX,
140 $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL,
141 $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ
142* ..
143* .. External Subroutines ..
144 EXTERNAL dlasq3, dlasrt, xerbla
145* ..
146* .. External Functions ..
147 INTEGER ILAENV
148 DOUBLE PRECISION DLAMCH
149 EXTERNAL dlamch, ilaenv
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC abs, dble, max, min, sqrt
153* ..
154* .. Executable Statements ..
155*
156* Test the input arguments.
157* (in case DLASQ2 is not called by DLASQ1)
158*
159 info = 0
160 eps = dlamch( 'Precision' )
161 safmin = dlamch( 'Safe minimum' )
162 tol = eps*hundrd
163 tol2 = tol**2
164*
165 IF( n.LT.0 ) THEN
166 info = -1
167 CALL xerbla( 'DLASQ2', 1 )
168 RETURN
169 ELSE IF( n.EQ.0 ) THEN
170 RETURN
171 ELSE IF( n.EQ.1 ) THEN
172*
173* 1-by-1 case.
174*
175 IF( z( 1 ).LT.zero ) THEN
176 info = -201
177 CALL xerbla( 'DLASQ2', 2 )
178 END IF
179 RETURN
180 ELSE IF( n.EQ.2 ) THEN
181*
182* 2-by-2 case.
183*
184 IF( z( 1 ).LT.zero ) THEN
185 info = -201
186 CALL xerbla( 'DLASQ2', 2 )
187 RETURN
188 ELSE IF( z( 2 ).LT.zero ) THEN
189 info = -202
190 CALL xerbla( 'DLASQ2', 2 )
191 RETURN
192 ELSE IF( z( 3 ).LT.zero ) THEN
193 info = -203
194 CALL xerbla( 'DLASQ2', 2 )
195 RETURN
196 ELSE IF( z( 3 ).GT.z( 1 ) ) THEN
197 d = z( 3 )
198 z( 3 ) = z( 1 )
199 z( 1 ) = d
200 END IF
201 z( 5 ) = z( 1 ) + z( 2 ) + z( 3 )
202 IF( z( 2 ).GT.z( 3 )*tol2 ) THEN
203 t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) )
204 s = z( 3 )*( z( 2 ) / t )
205 IF( s.LE.t ) THEN
206 s = z( 3 )*( z( 2 ) / ( t*( one+sqrt( one+s / t ) ) ) )
207 ELSE
208 s = z( 3 )*( z( 2 ) / ( t+sqrt( t )*sqrt( t+s ) ) )
209 END IF
210 t = z( 1 ) + ( s+z( 2 ) )
211 z( 3 ) = z( 3 )*( z( 1 ) / t )
212 z( 1 ) = t
213 END IF
214 z( 2 ) = z( 3 )
215 z( 6 ) = z( 2 ) + z( 1 )
216 RETURN
217 END IF
218*
219* Check for negative data and compute sums of q's and e's.
220*
221 z( 2*n ) = zero
222 emin = z( 2 )
223 qmax = zero
224 zmax = zero
225 d = zero
226 e = zero
227*
228 DO 10 k = 1, 2*( n-1 ), 2
229 IF( z( k ).LT.zero ) THEN
230 info = -( 200+k )
231 CALL xerbla( 'DLASQ2', 2 )
232 RETURN
233 ELSE IF( z( k+1 ).LT.zero ) THEN
234 info = -( 200+k+1 )
235 CALL xerbla( 'DLASQ2', 2 )
236 RETURN
237 END IF
238 d = d + z( k )
239 e = e + z( k+1 )
240 qmax = max( qmax, z( k ) )
241 emin = min( emin, z( k+1 ) )
242 zmax = max( qmax, zmax, z( k+1 ) )
243 10 CONTINUE
244 IF( z( 2*n-1 ).LT.zero ) THEN
245 info = -( 200+2*n-1 )
246 CALL xerbla( 'DLASQ2', 2 )
247 RETURN
248 END IF
249 d = d + z( 2*n-1 )
250 qmax = max( qmax, z( 2*n-1 ) )
251 zmax = max( qmax, zmax )
252*
253* Check for diagonality.
254*
255 IF( e.EQ.zero ) THEN
256 DO 20 k = 2, n
257 z( k ) = z( 2*k-1 )
258 20 CONTINUE
259 CALL dlasrt( 'D', n, z, iinfo )
260 z( 2*n-1 ) = d
261 RETURN
262 END IF
263*
264 trace = d + e
265*
266* Check for zero data.
267*
268 IF( trace.EQ.zero ) THEN
269 z( 2*n-1 ) = zero
270 RETURN
271 END IF
272*
273* Check whether the machine is IEEE conformable.
274*
275 ieee = ( ilaenv( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 )
276*
277* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
278*
279 DO 30 k = 2*n, 2, -2
280 z( 2*k ) = zero
281 z( 2*k-1 ) = z( k )
282 z( 2*k-2 ) = zero
283 z( 2*k-3 ) = z( k-1 )
284 30 CONTINUE
285*
286 i0 = 1
287 n0 = n
288*
289* Reverse the qd-array, if warranted.
290*
291 IF( cbias*z( 4*i0-3 ).LT.z( 4*n0-3 ) ) THEN
292 ipn4 = 4*( i0+n0 )
293 DO 40 i4 = 4*i0, 2*( i0+n0-1 ), 4
294 temp = z( i4-3 )
295 z( i4-3 ) = z( ipn4-i4-3 )
296 z( ipn4-i4-3 ) = temp
297 temp = z( i4-1 )
298 z( i4-1 ) = z( ipn4-i4-5 )
299 z( ipn4-i4-5 ) = temp
300 40 CONTINUE
301 END IF
302*
303* Initial split checking via dqd and Li's test.
304*
305 pp = 0
306*
307 DO 80 k = 1, 2
308*
309 d = z( 4*n0+pp-3 )
310 DO 50 i4 = 4*( n0-1 ) + pp, 4*i0 + pp, -4
311 IF( z( i4-1 ).LE.tol2*d ) THEN
312 z( i4-1 ) = -zero
313 d = z( i4-3 )
314 ELSE
315 d = z( i4-3 )*( d / ( d+z( i4-1 ) ) )
316 END IF
317 50 CONTINUE
318*
319* dqd maps Z to ZZ plus Li's test.
320*
321 emin = z( 4*i0+pp+1 )
322 d = z( 4*i0+pp-3 )
323 DO 60 i4 = 4*i0 + pp, 4*( n0-1 ) + pp, 4
324 z( i4-2*pp-2 ) = d + z( i4-1 )
325 IF( z( i4-1 ).LE.tol2*d ) THEN
326 z( i4-1 ) = -zero
327 z( i4-2*pp-2 ) = d
328 z( i4-2*pp ) = zero
329 d = z( i4+1 )
330 ELSE IF( safmin*z( i4+1 ).LT.z( i4-2*pp-2 ) .AND.
331 $ safmin*z( i4-2*pp-2 ).LT.z( i4+1 ) ) THEN
332 temp = z( i4+1 ) / z( i4-2*pp-2 )
333 z( i4-2*pp ) = z( i4-1 )*temp
334 d = d*temp
335 ELSE
336 z( i4-2*pp ) = z( i4+1 )*( z( i4-1 ) / z( i4-2*pp-2 ) )
337 d = z( i4+1 )*( d / z( i4-2*pp-2 ) )
338 END IF
339 emin = min( emin, z( i4-2*pp ) )
340 60 CONTINUE
341 z( 4*n0-pp-2 ) = d
342*
343* Now find qmax.
344*
345 qmax = z( 4*i0-pp-2 )
346 DO 70 i4 = 4*i0 - pp + 2, 4*n0 - pp - 2, 4
347 qmax = max( qmax, z( i4 ) )
348 70 CONTINUE
349*
350* Prepare for the next iteration on K.
351*
352 pp = 1 - pp
353 80 CONTINUE
354*
355* Initialise variables to pass to DLASQ3.
356*
357 ttype = 0
358 dmin1 = zero
359 dmin2 = zero
360 dn = zero
361 dn1 = zero
362 dn2 = zero
363 g = zero
364 tau = zero
365*
366 iter = 2
367 nfail = 0
368 ndiv = 2*( n0-i0 )
369*
370 DO 160 iwhila = 1, n + 1
371 IF( n0.LT.1 )
372 $ GO TO 170
373*
374* While array unfinished do
375*
376* E(N0) holds the value of SIGMA when submatrix in I0:N0
377* splits from the rest of the array, but is negated.
378*
379 desig = zero
380 IF( n0.EQ.n ) THEN
381 sigma = zero
382 ELSE
383 sigma = -z( 4*n0-1 )
384 END IF
385 IF( sigma.LT.zero ) THEN
386 info = 1
387 RETURN
388 END IF
389*
390* Find last unreduced submatrix's top index I0, find QMAX and
391* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
392*
393 emax = zero
394 IF( n0.GT.i0 ) THEN
395 emin = abs( z( 4*n0-5 ) )
396 ELSE
397 emin = zero
398 END IF
399 qmin = z( 4*n0-3 )
400 qmax = qmin
401 DO 90 i4 = 4*n0, 8, -4
402 IF( z( i4-5 ).LE.zero )
403 $ GO TO 100
404 IF( qmin.GE.four*emax ) THEN
405 qmin = min( qmin, z( i4-3 ) )
406 emax = max( emax, z( i4-5 ) )
407 END IF
408 qmax = max( qmax, z( i4-7 )+z( i4-5 ) )
409 emin = min( emin, z( i4-5 ) )
410 90 CONTINUE
411 i4 = 4
412*
413 100 CONTINUE
414 i0 = i4 / 4
415 pp = 0
416*
417 IF( n0-i0.GT.1 ) THEN
418 dee = z( 4*i0-3 )
419 deemin = dee
420 kmin = i0
421 DO 110 i4 = 4*i0+1, 4*n0-3, 4
422 dee = z( i4 )*( dee /( dee+z( i4-2 ) ) )
423 IF( dee.LE.deemin ) THEN
424 deemin = dee
425 kmin = ( i4+3 )/4
426 END IF
427 110 CONTINUE
428 IF( (kmin-i0)*2.LT.n0-kmin .AND.
429 $ deemin.LE.half*z(4*n0-3) ) THEN
430 ipn4 = 4*( i0+n0 )
431 pp = 2
432 DO 120 i4 = 4*i0, 2*( i0+n0-1 ), 4
433 temp = z( i4-3 )
434 z( i4-3 ) = z( ipn4-i4-3 )
435 z( ipn4-i4-3 ) = temp
436 temp = z( i4-2 )
437 z( i4-2 ) = z( ipn4-i4-2 )
438 z( ipn4-i4-2 ) = temp
439 temp = z( i4-1 )
440 z( i4-1 ) = z( ipn4-i4-5 )
441 z( ipn4-i4-5 ) = temp
442 temp = z( i4 )
443 z( i4 ) = z( ipn4-i4-4 )
444 z( ipn4-i4-4 ) = temp
445 120 CONTINUE
446 END IF
447 END IF
448*
449* Put -(initial shift) into DMIN.
450*
451 dmin = -max( zero, qmin-two*sqrt( qmin )*sqrt( emax ) )
452*
453* Now I0:N0 is unreduced.
454* PP = 0 for ping, PP = 1 for pong.
455* PP = 2 indicates that flipping was applied to the Z array and
456* and that the tests for deflation upon entry in DLASQ3
457* should not be performed.
458*
459 nbig = 100*( n0-i0+1 )
460 DO 140 iwhilb = 1, nbig
461 IF( i0.GT.n0 )
462 $ GO TO 150
463*
464* While submatrix unfinished take a good dqds step.
465*
466 CALL dlasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,
467 $ iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1,
468 $ dn2, g, tau )
469*
470 pp = 1 - pp
471*
472* When EMIN is very small check for splits.
473*
474 IF( pp.EQ.0 .AND. n0-i0.GE.3 ) THEN
475 IF( z( 4*n0 ).LE.tol2*qmax .OR.
476 $ z( 4*n0-1 ).LE.tol2*sigma ) THEN
477 splt = i0 - 1
478 qmax = z( 4*i0-3 )
479 emin = z( 4*i0-1 )
480 oldemn = z( 4*i0 )
481 DO 130 i4 = 4*i0, 4*( n0-3 ), 4
482 IF( z( i4 ).LE.tol2*z( i4-3 ) .OR.
483 $ z( i4-1 ).LE.tol2*sigma ) THEN
484 z( i4-1 ) = -sigma
485 splt = i4 / 4
486 qmax = zero
487 emin = z( i4+3 )
488 oldemn = z( i4+4 )
489 ELSE
490 qmax = max( qmax, z( i4+1 ) )
491 emin = min( emin, z( i4-1 ) )
492 oldemn = min( oldemn, z( i4 ) )
493 END IF
494 130 CONTINUE
495 z( 4*n0-1 ) = emin
496 z( 4*n0 ) = oldemn
497 i0 = splt + 1
498 END IF
499 END IF
500*
501 140 CONTINUE
502*
503 info = 2
504*
505* Maximum number of iterations exceeded, restore the shift
506* SIGMA and place the new d's and e's in a qd array.
507* This might need to be done for several blocks
508*
509 i1 = i0
510 n1 = n0
511 145 CONTINUE
512 tempq = z( 4*i0-3 )
513 z( 4*i0-3 ) = z( 4*i0-3 ) + sigma
514 DO k = i0+1, n0
515 tempe = z( 4*k-5 )
516 z( 4*k-5 ) = z( 4*k-5 ) * (tempq / z( 4*k-7 ))
517 tempq = z( 4*k-3 )
518 z( 4*k-3 ) = z( 4*k-3 ) + sigma + tempe - z( 4*k-5 )
519 END DO
520*
521* Prepare to do this on the previous block if there is one
522*
523 IF( i1.GT.1 ) THEN
524 n1 = i1-1
525 DO WHILE( ( i1.GE.2 ) .AND. ( z(4*i1-5).GE.zero ) )
526 i1 = i1 - 1
527 END DO
528 sigma = -z(4*n1-1)
529 GO TO 145
530 END IF
531
532 DO k = 1, n
533 z( 2*k-1 ) = z( 4*k-3 )
534*
535* Only the block 1..N0 is unfinished. The rest of the e's
536* must be essentially zero, although sometimes other data
537* has been stored in them.
538*
539 IF( k.LT.n0 ) THEN
540 z( 2*k ) = z( 4*k-1 )
541 ELSE
542 z( 2*k ) = 0
543 END IF
544 END DO
545 RETURN
546*
547* end IWHILB
548*
549 150 CONTINUE
550*
551 160 CONTINUE
552*
553 info = 3
554 RETURN
555*
556* end IWHILA
557*
558 170 CONTINUE
559*
560* Move q's to the front.
561*
562 DO 180 k = 2, n
563 z( k ) = z( 4*k-3 )
564 180 CONTINUE
565*
566* Sort and compute sum of eigenvalues.
567*
568 CALL dlasrt( 'D', n, z, iinfo )
569*
570 e = zero
571 DO 190 k = n, 1, -1
572 e = e + z( k )
573 190 CONTINUE
574*
575* Store trace, sum(eigenvalues) and information on performance.
576*
577 z( 2*n+1 ) = trace
578 z( 2*n+2 ) = e
579 z( 2*n+3 ) = dble( iter )
580 z( 2*n+4 ) = dble( ndiv ) / dble( n**2 )
581 z( 2*n+5 ) = hundrd*nfail / dble( iter )
582 RETURN
583*
584* End of DLASQ2
585*
dlasq3
subroutine dlasq3(i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)
DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.
Definition dlasq3.f:182

◆ dlasq3()

subroutine dlasq3 ( integer i0,
integer n0,
double precision, dimension( * ) z,
integer pp,
double precision dmin,
double precision sigma,
double precision desig,
double precision qmax,
integer nfail,
integer iter,
integer ndiv,
logical ieee,
integer ttype,
double precision dmin1,
double precision dmin2,
double precision dn,
double precision dn1,
double precision dn2,
double precision g,
double precision tau )

DLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.

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

Purpose:
!>
!> DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
!> In case of failure it changes shifts, and tries again until output
!> is positive.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>         First index.
!>
[in,out]N0
!>          N0 is INTEGER
!>         Last index.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N0 )
!>         Z holds the qd array.
!>
[in,out]PP
!>          PP is INTEGER
!>         PP=0 for ping, PP=1 for pong.
!>         PP=2 indicates that flipping was applied to the Z array
!>         and that the initial tests for deflation should not be
!>         performed.
!>
[out]DMIN
!>          DMIN is DOUBLE PRECISION
!>         Minimum value of d.
!>
[out]SIGMA
!>          SIGMA is DOUBLE PRECISION
!>         Sum of shifts used in current segment.
!>
[in,out]DESIG
!>          DESIG is DOUBLE PRECISION
!>         Lower order part of SIGMA
!>
[in]QMAX
!>          QMAX is DOUBLE PRECISION
!>         Maximum value of q.
!>
[in,out]NFAIL
!>          NFAIL is INTEGER
!>         Increment NFAIL by 1 each time the shift was too big.
!>
[in,out]ITER
!>          ITER is INTEGER
!>         Increment ITER by 1 for each iteration.
!>
[in,out]NDIV
!>          NDIV is INTEGER
!>         Increment NDIV by 1 for each division.
!>
[in]IEEE
!>          IEEE is LOGICAL
!>         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
!>
[in,out]TTYPE
!>          TTYPE is INTEGER
!>         Shift type.
!>
[in,out]DMIN1
!>          DMIN1 is DOUBLE PRECISION
!>
[in,out]DMIN2
!>          DMIN2 is DOUBLE PRECISION
!>
[in,out]DN
!>          DN is DOUBLE PRECISION
!>
[in,out]DN1
!>          DN1 is DOUBLE PRECISION
!>
[in,out]DN2
!>          DN2 is DOUBLE PRECISION
!>
[in,out]G
!>          G is DOUBLE PRECISION
!>
[in,out]TAU
!>          TAU is DOUBLE PRECISION
!>
!>         These are passed as arguments in order to save their values
!>         between calls to DLASQ3.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 179 of file dlasq3.f.

182*
183* -- LAPACK computational routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 LOGICAL IEEE
189 INTEGER I0, ITER, N0, NDIV, NFAIL, PP
190 DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
191 $ QMAX, SIGMA, TAU
192* ..
193* .. Array Arguments ..
194 DOUBLE PRECISION Z( * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 DOUBLE PRECISION CBIAS
201 parameter( cbias = 1.50d0 )
202 DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
203 parameter( zero = 0.0d0, qurtr = 0.250d0, half = 0.5d0,
204 $ one = 1.0d0, two = 2.0d0, hundrd = 100.0d0 )
205* ..
206* .. Local Scalars ..
207 INTEGER IPN4, J4, N0IN, NN, TTYPE
208 DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2
209* ..
210* .. External Subroutines ..
211 EXTERNAL dlasq4, dlasq5, dlasq6
212* ..
213* .. External Function ..
214 DOUBLE PRECISION DLAMCH
215 LOGICAL DISNAN
216 EXTERNAL disnan, dlamch
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC abs, max, min, sqrt
220* ..
221* .. Executable Statements ..
222*
223 n0in = n0
224 eps = dlamch( 'Precision' )
225 tol = eps*hundrd
226 tol2 = tol**2
227*
228* Check for deflation.
229*
230 10 CONTINUE
231*
232 IF( n0.LT.i0 )
233 $ RETURN
234 IF( n0.EQ.i0 )
235 $ GO TO 20
236 nn = 4*n0 + pp
237 IF( n0.EQ.( i0+1 ) )
238 $ GO TO 40
239*
240* Check whether E(N0-1) is negligible, 1 eigenvalue.
241*
242 IF( z( nn-5 ).GT.tol2*( sigma+z( nn-3 ) ) .AND.
243 $ z( nn-2*pp-4 ).GT.tol2*z( nn-7 ) )
244 $ GO TO 30
245*
246 20 CONTINUE
247*
248 z( 4*n0-3 ) = z( 4*n0+pp-3 ) + sigma
249 n0 = n0 - 1
250 GO TO 10
251*
252* Check whether E(N0-2) is negligible, 2 eigenvalues.
253*
254 30 CONTINUE
255*
256 IF( z( nn-9 ).GT.tol2*sigma .AND.
257 $ z( nn-2*pp-8 ).GT.tol2*z( nn-11 ) )
258 $ GO TO 50
259*
260 40 CONTINUE
261*
262 IF( z( nn-3 ).GT.z( nn-7 ) ) THEN
263 s = z( nn-3 )
264 z( nn-3 ) = z( nn-7 )
265 z( nn-7 ) = s
266 END IF
267 t = half*( ( z( nn-7 )-z( nn-3 ) )+z( nn-5 ) )
268 IF( z( nn-5 ).GT.z( nn-3 )*tol2.AND.t.NE.zero ) THEN
269 s = z( nn-3 )*( z( nn-5 ) / t )
270 IF( s.LE.t ) THEN
271 s = z( nn-3 )*( z( nn-5 ) /
272 $ ( t*( one+sqrt( one+s / t ) ) ) )
273 ELSE
274 s = z( nn-3 )*( z( nn-5 ) / ( t+sqrt( t )*sqrt( t+s ) ) )
275 END IF
276 t = z( nn-7 ) + ( s+z( nn-5 ) )
277 z( nn-3 ) = z( nn-3 )*( z( nn-7 ) / t )
278 z( nn-7 ) = t
279 END IF
280 z( 4*n0-7 ) = z( nn-7 ) + sigma
281 z( 4*n0-3 ) = z( nn-3 ) + sigma
282 n0 = n0 - 2
283 GO TO 10
284*
285 50 CONTINUE
286 IF( pp.EQ.2 )
287 $ pp = 0
288*
289* Reverse the qd-array, if warranted.
290*
291 IF( dmin.LE.zero .OR. n0.LT.n0in ) THEN
292 IF( cbias*z( 4*i0+pp-3 ).LT.z( 4*n0+pp-3 ) ) THEN
293 ipn4 = 4*( i0+n0 )
294 DO 60 j4 = 4*i0, 2*( i0+n0-1 ), 4
295 temp = z( j4-3 )
296 z( j4-3 ) = z( ipn4-j4-3 )
297 z( ipn4-j4-3 ) = temp
298 temp = z( j4-2 )
299 z( j4-2 ) = z( ipn4-j4-2 )
300 z( ipn4-j4-2 ) = temp
301 temp = z( j4-1 )
302 z( j4-1 ) = z( ipn4-j4-5 )
303 z( ipn4-j4-5 ) = temp
304 temp = z( j4 )
305 z( j4 ) = z( ipn4-j4-4 )
306 z( ipn4-j4-4 ) = temp
307 60 CONTINUE
308 IF( n0-i0.LE.4 ) THEN
309 z( 4*n0+pp-1 ) = z( 4*i0+pp-1 )
310 z( 4*n0-pp ) = z( 4*i0-pp )
311 END IF
312 dmin2 = min( dmin2, z( 4*n0+pp-1 ) )
313 z( 4*n0+pp-1 ) = min( z( 4*n0+pp-1 ), z( 4*i0+pp-1 ),
314 $ z( 4*i0+pp+3 ) )
315 z( 4*n0-pp ) = min( z( 4*n0-pp ), z( 4*i0-pp ),
316 $ z( 4*i0-pp+4 ) )
317 qmax = max( qmax, z( 4*i0+pp-3 ), z( 4*i0+pp+1 ) )
318 dmin = -zero
319 END IF
320 END IF
321*
322* Choose a shift.
323*
324 CALL dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1,
325 $ dn2, tau, ttype, g )
326*
327* Call dqds until DMIN > 0.
328*
329 70 CONTINUE
330*
331 CALL dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,
332 $ dn1, dn2, ieee, eps )
333*
334 ndiv = ndiv + ( n0-i0+2 )
335 iter = iter + 1
336*
337* Check status.
338*
339 IF( dmin.GE.zero .AND. dmin1.GE.zero ) THEN
340*
341* Success.
342*
343 GO TO 90
344*
345 ELSE IF( dmin.LT.zero .AND. dmin1.GT.zero .AND.
346 $ z( 4*( n0-1 )-pp ).LT.tol*( sigma+dn1 ) .AND.
347 $ abs( dn ).LT.tol*sigma ) THEN
348*
349* Convergence hidden by negative DN.
350*
351 z( 4*( n0-1 )-pp+2 ) = zero
352 dmin = zero
353 GO TO 90
354 ELSE IF( dmin.LT.zero ) THEN
355*
356* TAU too big. Select new TAU and try again.
357*
358 nfail = nfail + 1
359 IF( ttype.LT.-22 ) THEN
360*
361* Failed twice. Play it safe.
362*
363 tau = zero
364 ELSE IF( dmin1.GT.zero ) THEN
365*
366* Late failure. Gives excellent shift.
367*
368 tau = ( tau+dmin )*( one-two*eps )
369 ttype = ttype - 11
370 ELSE
371*
372* Early failure. Divide by 4.
373*
374 tau = qurtr*tau
375 ttype = ttype - 12
376 END IF
377 GO TO 70
378 ELSE IF( disnan( dmin ) ) THEN
379*
380* NaN.
381*
382 IF( tau.EQ.zero ) THEN
383 GO TO 80
384 ELSE
385 tau = zero
386 GO TO 70
387 END IF
388 ELSE
389*
390* Possible underflow. Play it safe.
391*
392 GO TO 80
393 END IF
394*
395* Risk of underflow.
396*
397 80 CONTINUE
398 CALL dlasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn, dn1, dn2 )
399 ndiv = ndiv + ( n0-i0+2 )
400 iter = iter + 1
401 tau = zero
402*
403 90 CONTINUE
404 IF( tau.LT.sigma ) THEN
405 desig = desig + tau
406 t = sigma + desig
407 desig = desig - ( t-sigma )
408 ELSE
409 t = sigma + tau
410 desig = sigma - ( t-tau ) + desig
411 END IF
412 sigma = t
413*
414 RETURN
415*
416* End of DLASQ3
417*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
dlasq6
subroutine dlasq6(i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
Definition dlasq6.f:119
dlasq5
subroutine dlasq5(i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn, dnm1, dnm2, ieee, eps)
DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
Definition dlasq5.f:144
dlasq4
subroutine dlasq4(i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous trans...
Definition dlasq4.f:151

◆ dlasq4()

subroutine dlasq4 ( integer i0,
integer n0,
double precision, dimension( * ) z,
integer pp,
integer n0in,
double precision dmin,
double precision dmin1,
double precision dmin2,
double precision dn,
double precision dn1,
double precision dn2,
double precision tau,
integer ttype,
double precision g )

DLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.

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

Purpose:
!>
!> DLASQ4 computes an approximation TAU to the smallest eigenvalue
!> using values of d from the previous transform.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N0 )
!>        Z holds the qd array.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[in]N0IN
!>          N0IN is INTEGER
!>        The value of N0 at start of EIGTEST.
!>
[in]DMIN
!>          DMIN is DOUBLE PRECISION
!>        Minimum value of d.
!>
[in]DMIN1
!>          DMIN1 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ).
!>
[in]DMIN2
!>          DMIN2 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[in]DN
!>          DN is DOUBLE PRECISION
!>        d(N)
!>
[in]DN1
!>          DN1 is DOUBLE PRECISION
!>        d(N-1)
!>
[in]DN2
!>          DN2 is DOUBLE PRECISION
!>        d(N-2)
!>
[out]TAU
!>          TAU is DOUBLE PRECISION
!>        This is the shift.
!>
[out]TTYPE
!>          TTYPE is INTEGER
!>        Shift type.
!>
[in,out]G
!>          G is DOUBLE PRECISION
!>        G is passed as an argument in order to save its value between
!>        calls to DLASQ4.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  CNST1 = 9/16
!>

Definition at line 149 of file dlasq4.f.

151*
152* -- LAPACK computational routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 INTEGER I0, N0, N0IN, PP, TTYPE
158 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
159* ..
160* .. Array Arguments ..
161 DOUBLE PRECISION Z( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 DOUBLE PRECISION CNST1, CNST2, CNST3
168 parameter( cnst1 = 0.5630d0, cnst2 = 1.010d0,
169 $ cnst3 = 1.050d0 )
170 DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
171 parameter( qurtr = 0.250d0, third = 0.3330d0,
172 $ half = 0.50d0, zero = 0.0d0, one = 1.0d0,
173 $ two = 2.0d0, hundrd = 100.0d0 )
174* ..
175* .. Local Scalars ..
176 INTEGER I4, NN, NP
177 DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC max, min, sqrt
181* ..
182* .. Executable Statements ..
183*
184* A negative DMIN forces the shift to take that absolute value
185* TTYPE records the type of shift.
186*
187 IF( dmin.LE.zero ) THEN
188 tau = -dmin
189 ttype = -1
190 RETURN
191 END IF
192*
193 nn = 4*n0 + pp
194 IF( n0in.EQ.n0 ) THEN
195*
196* No eigenvalues deflated.
197*
198 IF( dmin.EQ.dn .OR. dmin.EQ.dn1 ) THEN
199*
200 b1 = sqrt( z( nn-3 ) )*sqrt( z( nn-5 ) )
201 b2 = sqrt( z( nn-7 ) )*sqrt( z( nn-9 ) )
202 a2 = z( nn-7 ) + z( nn-5 )
203*
204* Cases 2 and 3.
205*
206 IF( dmin.EQ.dn .AND. dmin1.EQ.dn1 ) THEN
207 gap2 = dmin2 - a2 - dmin2*qurtr
208 IF( gap2.GT.zero .AND. gap2.GT.b2 ) THEN
209 gap1 = a2 - dn - ( b2 / gap2 )*b2
210 ELSE
211 gap1 = a2 - dn - ( b1+b2 )
212 END IF
213 IF( gap1.GT.zero .AND. gap1.GT.b1 ) THEN
214 s = max( dn-( b1 / gap1 )*b1, half*dmin )
215 ttype = -2
216 ELSE
217 s = zero
218 IF( dn.GT.b1 )
219 $ s = dn - b1
220 IF( a2.GT.( b1+b2 ) )
221 $ s = min( s, a2-( b1+b2 ) )
222 s = max( s, third*dmin )
223 ttype = -3
224 END IF
225 ELSE
226*
227* Case 4.
228*
229 ttype = -4
230 s = qurtr*dmin
231 IF( dmin.EQ.dn ) THEN
232 gam = dn
233 a2 = zero
234 IF( z( nn-5 ) .GT. z( nn-7 ) )
235 $ RETURN
236 b2 = z( nn-5 ) / z( nn-7 )
237 np = nn - 9
238 ELSE
239 np = nn - 2*pp
240 gam = dn1
241 IF( z( np-4 ) .GT. z( np-2 ) )
242 $ RETURN
243 a2 = z( np-4 ) / z( np-2 )
244 IF( z( nn-9 ) .GT. z( nn-11 ) )
245 $ RETURN
246 b2 = z( nn-9 ) / z( nn-11 )
247 np = nn - 13
248 END IF
249*
250* Approximate contribution to norm squared from I < NN-1.
251*
252 a2 = a2 + b2
253 DO 10 i4 = np, 4*i0 - 1 + pp, -4
254 IF( b2.EQ.zero )
255 $ GO TO 20
256 b1 = b2
257 IF( z( i4 ) .GT. z( i4-2 ) )
258 $ RETURN
259 b2 = b2*( z( i4 ) / z( i4-2 ) )
260 a2 = a2 + b2
261 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
262 $ GO TO 20
263 10 CONTINUE
264 20 CONTINUE
265 a2 = cnst3*a2
266*
267* Rayleigh quotient residual bound.
268*
269 IF( a2.LT.cnst1 )
270 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
271 END IF
272 ELSE IF( dmin.EQ.dn2 ) THEN
273*
274* Case 5.
275*
276 ttype = -5
277 s = qurtr*dmin
278*
279* Compute contribution to norm squared from I > NN-2.
280*
281 np = nn - 2*pp
282 b1 = z( np-2 )
283 b2 = z( np-6 )
284 gam = dn2
285 IF( z( np-8 ).GT.b2 .OR. z( np-4 ).GT.b1 )
286 $ RETURN
287 a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 )
288*
289* Approximate contribution to norm squared from I < NN-2.
290*
291 IF( n0-i0.GT.2 ) THEN
292 b2 = z( nn-13 ) / z( nn-15 )
293 a2 = a2 + b2
294 DO 30 i4 = nn - 17, 4*i0 - 1 + pp, -4
295 IF( b2.EQ.zero )
296 $ GO TO 40
297 b1 = b2
298 IF( z( i4 ) .GT. z( i4-2 ) )
299 $ RETURN
300 b2 = b2*( z( i4 ) / z( i4-2 ) )
301 a2 = a2 + b2
302 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
303 $ GO TO 40
304 30 CONTINUE
305 40 CONTINUE
306 a2 = cnst3*a2
307 END IF
308*
309 IF( a2.LT.cnst1 )
310 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
311 ELSE
312*
313* Case 6, no information to guide us.
314*
315 IF( ttype.EQ.-6 ) THEN
316 g = g + third*( one-g )
317 ELSE IF( ttype.EQ.-18 ) THEN
318 g = qurtr*third
319 ELSE
320 g = qurtr
321 END IF
322 s = g*dmin
323 ttype = -6
324 END IF
325*
326 ELSE IF( n0in.EQ.( n0+1 ) ) THEN
327*
328* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
329*
330 IF( dmin1.EQ.dn1 .AND. dmin2.EQ.dn2 ) THEN
331*
332* Cases 7 and 8.
333*
334 ttype = -7
335 s = third*dmin1
336 IF( z( nn-5 ).GT.z( nn-7 ) )
337 $ RETURN
338 b1 = z( nn-5 ) / z( nn-7 )
339 b2 = b1
340 IF( b2.EQ.zero )
341 $ GO TO 60
342 DO 50 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
343 a2 = b1
344 IF( z( i4 ).GT.z( i4-2 ) )
345 $ RETURN
346 b1 = b1*( z( i4 ) / z( i4-2 ) )
347 b2 = b2 + b1
348 IF( hundrd*max( b1, a2 ).LT.b2 )
349 $ GO TO 60
350 50 CONTINUE
351 60 CONTINUE
352 b2 = sqrt( cnst3*b2 )
353 a2 = dmin1 / ( one+b2**2 )
354 gap2 = half*dmin2 - a2
355 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
356 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
357 ELSE
358 s = max( s, a2*( one-cnst2*b2 ) )
359 ttype = -8
360 END IF
361 ELSE
362*
363* Case 9.
364*
365 s = qurtr*dmin1
366 IF( dmin1.EQ.dn1 )
367 $ s = half*dmin1
368 ttype = -9
369 END IF
370*
371 ELSE IF( n0in.EQ.( n0+2 ) ) THEN
372*
373* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
374*
375* Cases 10 and 11.
376*
377 IF( dmin2.EQ.dn2 .AND. two*z( nn-5 ).LT.z( nn-7 ) ) THEN
378 ttype = -10
379 s = third*dmin2
380 IF( z( nn-5 ).GT.z( nn-7 ) )
381 $ RETURN
382 b1 = z( nn-5 ) / z( nn-7 )
383 b2 = b1
384 IF( b2.EQ.zero )
385 $ GO TO 80
386 DO 70 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
387 IF( z( i4 ).GT.z( i4-2 ) )
388 $ RETURN
389 b1 = b1*( z( i4 ) / z( i4-2 ) )
390 b2 = b2 + b1
391 IF( hundrd*b1.LT.b2 )
392 $ GO TO 80
393 70 CONTINUE
394 80 CONTINUE
395 b2 = sqrt( cnst3*b2 )
396 a2 = dmin2 / ( one+b2**2 )
397 gap2 = z( nn-7 ) + z( nn-9 ) -
398 $ sqrt( z( nn-11 ) )*sqrt( z( nn-9 ) ) - a2
399 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
400 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
401 ELSE
402 s = max( s, a2*( one-cnst2*b2 ) )
403 END IF
404 ELSE
405 s = qurtr*dmin2
406 ttype = -11
407 END IF
408 ELSE IF( n0in.GT.( n0+2 ) ) THEN
409*
410* Case 12, more than two eigenvalues deflated. No information.
411*
412 s = zero
413 ttype = -12
414 END IF
415*
416 tau = s
417 RETURN
418*
419* End of DLASQ4
420*

◆ dlasq5()

subroutine dlasq5 ( integer i0,
integer n0,
double precision, dimension( * ) z,
integer pp,
double precision tau,
double precision sigma,
double precision dmin,
double precision dmin1,
double precision dmin2,
double precision dn,
double precision dnm1,
double precision dnm2,
logical ieee,
double precision eps )

DLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> DLASQ5 computes one dqds transform in ping-pong form, one
!> version for IEEE machines another for non IEEE machines.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N )
!>        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!>        an extra argument.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION
!>        This is the shift.
!>
[in]SIGMA
!>          SIGMA is DOUBLE PRECISION
!>        This is the accumulated shift up to this step.
!>
[out]DMIN
!>          DMIN is DOUBLE PRECISION
!>        Minimum value of d.
!>
[out]DMIN1
!>          DMIN1 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ).
!>
[out]DMIN2
!>          DMIN2 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[out]DN
!>          DN is DOUBLE PRECISION
!>        d(N0), the last value of d.
!>
[out]DNM1
!>          DNM1 is DOUBLE PRECISION
!>        d(N0-1).
!>
[out]DNM2
!>          DNM2 is DOUBLE PRECISION
!>        d(N0-2).
!>
[in]IEEE
!>          IEEE is LOGICAL
!>        Flag for IEEE or non IEEE arithmetic.
!>
[in]EPS
!>          EPS is DOUBLE PRECISION
!>        This is the value of epsilon used.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file dlasq5.f.

144*
145* -- LAPACK computational routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149* .. Scalar Arguments ..
150 LOGICAL IEEE
151 INTEGER I0, N0, PP
152 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU,
153 $ SIGMA, EPS
154* ..
155* .. Array Arguments ..
156 DOUBLE PRECISION Z( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameter ..
162 DOUBLE PRECISION ZERO, HALF
163 parameter( zero = 0.0d0, half = 0.5 )
164* ..
165* .. Local Scalars ..
166 INTEGER J4, J4P2
167 DOUBLE PRECISION D, EMIN, TEMP, DTHRESH
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC min
171* ..
172* .. Executable Statements ..
173*
174 IF( ( n0-i0-1 ).LE.0 )
175 $ RETURN
176*
177 dthresh = eps*(sigma+tau)
178 IF( tau.LT.dthresh*half ) tau = zero
179 IF( tau.NE.zero ) THEN
180 j4 = 4*i0 + pp - 3
181 emin = z( j4+4 )
182 d = z( j4 ) - tau
183 dmin = d
184 dmin1 = -z( j4 )
185*
186 IF( ieee ) THEN
187*
188* Code for IEEE arithmetic.
189*
190 IF( pp.EQ.0 ) THEN
191 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
192 z( j4-2 ) = d + z( j4-1 )
193 temp = z( j4+1 ) / z( j4-2 )
194 d = d*temp - tau
195 dmin = min( dmin, d )
196 z( j4 ) = z( j4-1 )*temp
197 emin = min( z( j4 ), emin )
198 10 CONTINUE
199 ELSE
200 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
201 z( j4-3 ) = d + z( j4 )
202 temp = z( j4+2 ) / z( j4-3 )
203 d = d*temp - tau
204 dmin = min( dmin, d )
205 z( j4-1 ) = z( j4 )*temp
206 emin = min( z( j4-1 ), emin )
207 20 CONTINUE
208 END IF
209*
210* Unroll last two steps.
211*
212 dnm2 = d
213 dmin2 = dmin
214 j4 = 4*( n0-2 ) - pp
215 j4p2 = j4 + 2*pp - 1
216 z( j4-2 ) = dnm2 + z( j4p2 )
217 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
218 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
219 dmin = min( dmin, dnm1 )
220*
221 dmin1 = dmin
222 j4 = j4 + 4
223 j4p2 = j4 + 2*pp - 1
224 z( j4-2 ) = dnm1 + z( j4p2 )
225 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
226 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
227 dmin = min( dmin, dn )
228*
229 ELSE
230*
231* Code for non IEEE arithmetic.
232*
233 IF( pp.EQ.0 ) THEN
234 DO 30 j4 = 4*i0, 4*( n0-3 ), 4
235 z( j4-2 ) = d + z( j4-1 )
236 IF( d.LT.zero ) THEN
237 RETURN
238 ELSE
239 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
240 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
241 END IF
242 dmin = min( dmin, d )
243 emin = min( emin, z( j4 ) )
244 30 CONTINUE
245 ELSE
246 DO 40 j4 = 4*i0, 4*( n0-3 ), 4
247 z( j4-3 ) = d + z( j4 )
248 IF( d.LT.zero ) THEN
249 RETURN
250 ELSE
251 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
252 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
253 END IF
254 dmin = min( dmin, d )
255 emin = min( emin, z( j4-1 ) )
256 40 CONTINUE
257 END IF
258*
259* Unroll last two steps.
260*
261 dnm2 = d
262 dmin2 = dmin
263 j4 = 4*( n0-2 ) - pp
264 j4p2 = j4 + 2*pp - 1
265 z( j4-2 ) = dnm2 + z( j4p2 )
266 IF( dnm2.LT.zero ) THEN
267 RETURN
268 ELSE
269 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
270 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
271 END IF
272 dmin = min( dmin, dnm1 )
273*
274 dmin1 = dmin
275 j4 = j4 + 4
276 j4p2 = j4 + 2*pp - 1
277 z( j4-2 ) = dnm1 + z( j4p2 )
278 IF( dnm1.LT.zero ) THEN
279 RETURN
280 ELSE
281 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
282 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
283 END IF
284 dmin = min( dmin, dn )
285*
286 END IF
287 ELSE
288* This is the version that sets d's to zero if they are small enough
289 j4 = 4*i0 + pp - 3
290 emin = z( j4+4 )
291 d = z( j4 ) - tau
292 dmin = d
293 dmin1 = -z( j4 )
294 IF( ieee ) THEN
295*
296* Code for IEEE arithmetic.
297*
298 IF( pp.EQ.0 ) THEN
299 DO 50 j4 = 4*i0, 4*( n0-3 ), 4
300 z( j4-2 ) = d + z( j4-1 )
301 temp = z( j4+1 ) / z( j4-2 )
302 d = d*temp - tau
303 IF( d.LT.dthresh ) d = zero
304 dmin = min( dmin, d )
305 z( j4 ) = z( j4-1 )*temp
306 emin = min( z( j4 ), emin )
307 50 CONTINUE
308 ELSE
309 DO 60 j4 = 4*i0, 4*( n0-3 ), 4
310 z( j4-3 ) = d + z( j4 )
311 temp = z( j4+2 ) / z( j4-3 )
312 d = d*temp - tau
313 IF( d.LT.dthresh ) d = zero
314 dmin = min( dmin, d )
315 z( j4-1 ) = z( j4 )*temp
316 emin = min( z( j4-1 ), emin )
317 60 CONTINUE
318 END IF
319*
320* Unroll last two steps.
321*
322 dnm2 = d
323 dmin2 = dmin
324 j4 = 4*( n0-2 ) - pp
325 j4p2 = j4 + 2*pp - 1
326 z( j4-2 ) = dnm2 + z( j4p2 )
327 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
328 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
329 dmin = min( dmin, dnm1 )
330*
331 dmin1 = dmin
332 j4 = j4 + 4
333 j4p2 = j4 + 2*pp - 1
334 z( j4-2 ) = dnm1 + z( j4p2 )
335 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
336 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
337 dmin = min( dmin, dn )
338*
339 ELSE
340*
341* Code for non IEEE arithmetic.
342*
343 IF( pp.EQ.0 ) THEN
344 DO 70 j4 = 4*i0, 4*( n0-3 ), 4
345 z( j4-2 ) = d + z( j4-1 )
346 IF( d.LT.zero ) THEN
347 RETURN
348 ELSE
349 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
350 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
351 END IF
352 IF( d.LT.dthresh) d = zero
353 dmin = min( dmin, d )
354 emin = min( emin, z( j4 ) )
355 70 CONTINUE
356 ELSE
357 DO 80 j4 = 4*i0, 4*( n0-3 ), 4
358 z( j4-3 ) = d + z( j4 )
359 IF( d.LT.zero ) THEN
360 RETURN
361 ELSE
362 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
363 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
364 END IF
365 IF( d.LT.dthresh) d = zero
366 dmin = min( dmin, d )
367 emin = min( emin, z( j4-1 ) )
368 80 CONTINUE
369 END IF
370*
371* Unroll last two steps.
372*
373 dnm2 = d
374 dmin2 = dmin
375 j4 = 4*( n0-2 ) - pp
376 j4p2 = j4 + 2*pp - 1
377 z( j4-2 ) = dnm2 + z( j4p2 )
378 IF( dnm2.LT.zero ) THEN
379 RETURN
380 ELSE
381 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
382 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
383 END IF
384 dmin = min( dmin, dnm1 )
385*
386 dmin1 = dmin
387 j4 = j4 + 4
388 j4p2 = j4 + 2*pp - 1
389 z( j4-2 ) = dnm1 + z( j4p2 )
390 IF( dnm1.LT.zero ) THEN
391 RETURN
392 ELSE
393 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
394 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
395 END IF
396 dmin = min( dmin, dn )
397*
398 END IF
399 END IF
400*
401 z( j4+2 ) = dn
402 z( 4*n0-pp ) = emin
403 RETURN
404*
405* End of DLASQ5
406*

◆ dlasq6()

subroutine dlasq6 ( integer i0,
integer n0,
double precision, dimension( * ) z,
integer pp,
double precision dmin,
double precision dmin1,
double precision dmin2,
double precision dn,
double precision dnm1,
double precision dnm2 )

DLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> DLASQ6 computes one dqd (shift equal to zero) transform in
!> ping-pong form, with protection against underflow and overflow.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension ( 4*N )
!>        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!>        an extra argument.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[out]DMIN
!>          DMIN is DOUBLE PRECISION
!>        Minimum value of d.
!>
[out]DMIN1
!>          DMIN1 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ).
!>
[out]DMIN2
!>          DMIN2 is DOUBLE PRECISION
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[out]DN
!>          DN is DOUBLE PRECISION
!>        d(N0), the last value of d.
!>
[out]DNM1
!>          DNM1 is DOUBLE PRECISION
!>        d(N0-1).
!>
[out]DNM2
!>          DNM2 is DOUBLE PRECISION
!>        d(N0-2).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file dlasq6.f.

119*
120* -- LAPACK computational routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER I0, N0, PP
126 DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
127* ..
128* .. Array Arguments ..
129 DOUBLE PRECISION Z( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameter ..
135 DOUBLE PRECISION ZERO
136 parameter( zero = 0.0d0 )
137* ..
138* .. Local Scalars ..
139 INTEGER J4, J4P2
140 DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
141* ..
142* .. External Function ..
143 DOUBLE PRECISION DLAMCH
144 EXTERNAL dlamch
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC min
148* ..
149* .. Executable Statements ..
150*
151 IF( ( n0-i0-1 ).LE.0 )
152 $ RETURN
153*
154 safmin = dlamch( 'Safe minimum' )
155 j4 = 4*i0 + pp - 3
156 emin = z( j4+4 )
157 d = z( j4 )
158 dmin = d
159*
160 IF( pp.EQ.0 ) THEN
161 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
162 z( j4-2 ) = d + z( j4-1 )
163 IF( z( j4-2 ).EQ.zero ) THEN
164 z( j4 ) = zero
165 d = z( j4+1 )
166 dmin = d
167 emin = zero
168 ELSE IF( safmin*z( j4+1 ).LT.z( j4-2 ) .AND.
169 $ safmin*z( j4-2 ).LT.z( j4+1 ) ) THEN
170 temp = z( j4+1 ) / z( j4-2 )
171 z( j4 ) = z( j4-1 )*temp
172 d = d*temp
173 ELSE
174 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
175 d = z( j4+1 )*( d / z( j4-2 ) )
176 END IF
177 dmin = min( dmin, d )
178 emin = min( emin, z( j4 ) )
179 10 CONTINUE
180 ELSE
181 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
182 z( j4-3 ) = d + z( j4 )
183 IF( z( j4-3 ).EQ.zero ) THEN
184 z( j4-1 ) = zero
185 d = z( j4+2 )
186 dmin = d
187 emin = zero
188 ELSE IF( safmin*z( j4+2 ).LT.z( j4-3 ) .AND.
189 $ safmin*z( j4-3 ).LT.z( j4+2 ) ) THEN
190 temp = z( j4+2 ) / z( j4-3 )
191 z( j4-1 ) = z( j4 )*temp
192 d = d*temp
193 ELSE
194 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
195 d = z( j4+2 )*( d / z( j4-3 ) )
196 END IF
197 dmin = min( dmin, d )
198 emin = min( emin, z( j4-1 ) )
199 20 CONTINUE
200 END IF
201*
202* Unroll last two steps.
203*
204 dnm2 = d
205 dmin2 = dmin
206 j4 = 4*( n0-2 ) - pp
207 j4p2 = j4 + 2*pp - 1
208 z( j4-2 ) = dnm2 + z( j4p2 )
209 IF( z( j4-2 ).EQ.zero ) THEN
210 z( j4 ) = zero
211 dnm1 = z( j4p2+2 )
212 dmin = dnm1
213 emin = zero
214 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
215 $ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
216 temp = z( j4p2+2 ) / z( j4-2 )
217 z( j4 ) = z( j4p2 )*temp
218 dnm1 = dnm2*temp
219 ELSE
220 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
221 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) )
222 END IF
223 dmin = min( dmin, dnm1 )
224*
225 dmin1 = dmin
226 j4 = j4 + 4
227 j4p2 = j4 + 2*pp - 1
228 z( j4-2 ) = dnm1 + z( j4p2 )
229 IF( z( j4-2 ).EQ.zero ) THEN
230 z( j4 ) = zero
231 dn = z( j4p2+2 )
232 dmin = dn
233 emin = zero
234 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
235 $ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
236 temp = z( j4p2+2 ) / z( j4-2 )
237 z( j4 ) = z( j4p2 )*temp
238 dn = dnm1*temp
239 ELSE
240 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
241 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) )
242 END IF
243 dmin = min( dmin, dn )
244*
245 z( j4+2 ) = dn
246 z( 4*n0-pp ) = emin
247 RETURN
248*
249* End of DLASQ6
250*

◆ dlasrt()

subroutine dlasrt ( character id,
integer n,
double precision, dimension( * ) d,
integer info )

DLASRT sorts numbers in increasing or decreasing order.

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

Purpose:
!>
!> Sort the numbers in D in increasing order (if ID = 'I') or
!> in decreasing order (if ID = 'D' ).
!>
!> Use Quick Sort, reverting to Insertion sort on arrays of
!> size <= 20. Dimension of STACK limits N to about 2**32.
!>
Parameters
[in]ID
!>          ID is CHARACTER*1
!>          = 'I': sort D in increasing order;
!>          = 'D': sort D in decreasing order.
!>
[in]N
!>          N is INTEGER
!>          The length of the array D.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the array to be sorted.
!>          On exit, D has been sorted into increasing order
!>          (D(1) <= ... <= D(N) ) or into decreasing order
!>          (D(1) >= ... >= D(N) ), depending on ID.
!>
[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 87 of file dlasrt.f.

88*
89* -- LAPACK computational routine --
90* -- LAPACK is a software package provided by Univ. of Tennessee, --
91* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92*
93* .. Scalar Arguments ..
94 CHARACTER ID
95 INTEGER INFO, N
96* ..
97* .. Array Arguments ..
98 DOUBLE PRECISION D( * )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 INTEGER SELECT
105 parameter( SELECT = 20 )
106* ..
107* .. Local Scalars ..
108 INTEGER DIR, ENDD, I, J, START, STKPNT
109 DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
110* ..
111* .. Local Arrays ..
112 INTEGER STACK( 2, 32 )
113* ..
114* .. External Functions ..
115 LOGICAL LSAME
116 EXTERNAL lsame
117* ..
118* .. External Subroutines ..
119 EXTERNAL xerbla
120* ..
121* .. Executable Statements ..
122*
123* Test the input parameters.
124*
125 info = 0
126 dir = -1
127 IF( lsame( id, 'D' ) ) THEN
128 dir = 0
129 ELSE IF( lsame( id, 'I' ) ) THEN
130 dir = 1
131 END IF
132 IF( dir.EQ.-1 ) THEN
133 info = -1
134 ELSE IF( n.LT.0 ) THEN
135 info = -2
136 END IF
137 IF( info.NE.0 ) THEN
138 CALL xerbla( 'DLASRT', -info )
139 RETURN
140 END IF
141*
142* Quick return if possible
143*
144 IF( n.LE.1 )
145 $ RETURN
146*
147 stkpnt = 1
148 stack( 1, 1 ) = 1
149 stack( 2, 1 ) = n
150 10 CONTINUE
151 start = stack( 1, stkpnt )
152 endd = stack( 2, stkpnt )
153 stkpnt = stkpnt - 1
154 IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
155*
156* Do Insertion sort on D( START:ENDD )
157*
158 IF( dir.EQ.0 ) THEN
159*
160* Sort into decreasing order
161*
162 DO 30 i = start + 1, endd
163 DO 20 j = i, start + 1, -1
164 IF( d( j ).GT.d( j-1 ) ) THEN
165 dmnmx = d( j )
166 d( j ) = d( j-1 )
167 d( j-1 ) = dmnmx
168 ELSE
169 GO TO 30
170 END IF
171 20 CONTINUE
172 30 CONTINUE
173*
174 ELSE
175*
176* Sort into increasing order
177*
178 DO 50 i = start + 1, endd
179 DO 40 j = i, start + 1, -1
180 IF( d( j ).LT.d( j-1 ) ) THEN
181 dmnmx = d( j )
182 d( j ) = d( j-1 )
183 d( j-1 ) = dmnmx
184 ELSE
185 GO TO 50
186 END IF
187 40 CONTINUE
188 50 CONTINUE
189*
190 END IF
191*
192 ELSE IF( endd-start.GT.SELECT ) THEN
193*
194* Partition D( START:ENDD ) and stack parts, largest one first
195*
196* Choose partition entry as median of 3
197*
198 d1 = d( start )
199 d2 = d( endd )
200 i = ( start+endd ) / 2
201 d3 = d( i )
202 IF( d1.LT.d2 ) THEN
203 IF( d3.LT.d1 ) THEN
204 dmnmx = d1
205 ELSE IF( d3.LT.d2 ) THEN
206 dmnmx = d3
207 ELSE
208 dmnmx = d2
209 END IF
210 ELSE
211 IF( d3.LT.d2 ) THEN
212 dmnmx = d2
213 ELSE IF( d3.LT.d1 ) THEN
214 dmnmx = d3
215 ELSE
216 dmnmx = d1
217 END IF
218 END IF
219*
220 IF( dir.EQ.0 ) THEN
221*
222* Sort into decreasing order
223*
224 i = start - 1
225 j = endd + 1
226 60 CONTINUE
227 70 CONTINUE
228 j = j - 1
229 IF( d( j ).LT.dmnmx )
230 $ GO TO 70
231 80 CONTINUE
232 i = i + 1
233 IF( d( i ).GT.dmnmx )
234 $ GO TO 80
235 IF( i.LT.j ) THEN
236 tmp = d( i )
237 d( i ) = d( j )
238 d( j ) = tmp
239 GO TO 60
240 END IF
241 IF( j-start.GT.endd-j-1 ) THEN
242 stkpnt = stkpnt + 1
243 stack( 1, stkpnt ) = start
244 stack( 2, stkpnt ) = j
245 stkpnt = stkpnt + 1
246 stack( 1, stkpnt ) = j + 1
247 stack( 2, stkpnt ) = endd
248 ELSE
249 stkpnt = stkpnt + 1
250 stack( 1, stkpnt ) = j + 1
251 stack( 2, stkpnt ) = endd
252 stkpnt = stkpnt + 1
253 stack( 1, stkpnt ) = start
254 stack( 2, stkpnt ) = j
255 END IF
256 ELSE
257*
258* Sort into increasing order
259*
260 i = start - 1
261 j = endd + 1
262 90 CONTINUE
263 100 CONTINUE
264 j = j - 1
265 IF( d( j ).GT.dmnmx )
266 $ GO TO 100
267 110 CONTINUE
268 i = i + 1
269 IF( d( i ).LT.dmnmx )
270 $ GO TO 110
271 IF( i.LT.j ) THEN
272 tmp = d( i )
273 d( i ) = d( j )
274 d( j ) = tmp
275 GO TO 90
276 END IF
277 IF( j-start.GT.endd-j-1 ) THEN
278 stkpnt = stkpnt + 1
279 stack( 1, stkpnt ) = start
280 stack( 2, stkpnt ) = j
281 stkpnt = stkpnt + 1
282 stack( 1, stkpnt ) = j + 1
283 stack( 2, stkpnt ) = endd
284 ELSE
285 stkpnt = stkpnt + 1
286 stack( 1, stkpnt ) = j + 1
287 stack( 2, stkpnt ) = endd
288 stkpnt = stkpnt + 1
289 stack( 1, stkpnt ) = start
290 stack( 2, stkpnt ) = j
291 END IF
292 END IF
293 END IF
294 IF( stkpnt.GT.0 )
295 $ GO TO 10
296 RETURN
297*
298* End of DLASRT
299*
id
initmumps id
Definition multiplerhs_example.m:4

◆ dstebz()

subroutine dstebz ( character range,
character order,
integer n,
double precision vl,
double precision vu,
integer il,
integer iu,
double precision abstol,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
integer m,
integer nsplit,
double precision, dimension( * ) w,
integer, dimension( * ) iblock,
integer, dimension( * ) isplit,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DSTEBZ

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

Purpose:
!>
!> DSTEBZ computes the eigenvalues of a symmetric tridiagonal
!> matrix T.  The user may ask for all eigenvalues, all eigenvalues
!> in the half-open interval (VL, VU], or the IL-th through IU-th
!> eigenvalues.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , 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]ABSTOL
!>          ABSTOL is DOUBLE PRECISION
!>          The absolute tolerance for the eigenvalues.  An eigenvalue
!>          (or cluster) is considered to be located if it has been
!>          determined to lie in an interval whose width is ABSTOL or
!>          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
!>          will be used, where |T| means the 1-norm of T.
!>
!>          Eigenvalues will be computed most accurately when ABSTOL is
!>          set to twice the underflow threshold 2*DLAMCH('S'), not zero.
!>
[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.
!>
[out]M
!>          M is INTEGER
!>          The actual number of eigenvalues found. 0 <= M <= N.
!>          (See also the description of INFO=2,3.)
!>
[out]NSPLIT
!>          NSPLIT is INTEGER
!>          The number of diagonal blocks in the matrix T.
!>          1 <= NSPLIT <= N.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          On exit, the first M elements of W will contain the
!>          eigenvalues.  (DSTEBZ may use the remaining N-M elements as
!>          workspace.)
!>
[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.  (DSTEBZ may use the remaining N-M elements as
!>          workspace.)
!>
[out]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]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:
!>  RELFAC  DOUBLE PRECISION, default = 2.0e0
!>          The relative tolerance.  An interval (a,b] lies within
!>           if  b-a < RELFAC*ulp*max(|a|,|b|),
!>          where  is the machine precision (distance from 1 to
!>          the next larger floating point number.)
!>
!>  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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 270 of file dstebz.f.

273*
274* -- LAPACK computational routine --
275* -- LAPACK is a software package provided by Univ. of Tennessee, --
276* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
277*
278* .. Scalar Arguments ..
279 CHARACTER ORDER, RANGE
280 INTEGER IL, INFO, IU, M, N, NSPLIT
281 DOUBLE PRECISION ABSTOL, VL, VU
282* ..
283* .. Array Arguments ..
284 INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
285 DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
286* ..
287*
288* =====================================================================
289*
290* .. Parameters ..
291 DOUBLE PRECISION ZERO, ONE, TWO, HALF
292 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
293 $ half = 1.0d0 / two )
294 DOUBLE PRECISION FUDGE, RELFAC
295 parameter( fudge = 2.1d0, relfac = 2.0d0 )
296* ..
297* .. Local Scalars ..
298 LOGICAL NCNVRG, TOOFEW
299 INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
300 $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
301 $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
302 $ NWU
303 DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
304 $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
305* ..
306* .. Local Arrays ..
307 INTEGER IDUMMA( 1 )
308* ..
309* .. External Functions ..
310 LOGICAL LSAME
311 INTEGER ILAENV
312 DOUBLE PRECISION DLAMCH
313 EXTERNAL lsame, ilaenv, dlamch
314* ..
315* .. External Subroutines ..
316 EXTERNAL dlaebz, xerbla
317* ..
318* .. Intrinsic Functions ..
319 INTRINSIC abs, int, log, max, min, sqrt
320* ..
321* .. Executable Statements ..
322*
323 info = 0
324*
325* Decode RANGE
326*
327 IF( lsame( range, 'A' ) ) THEN
328 irange = 1
329 ELSE IF( lsame( range, 'V' ) ) THEN
330 irange = 2
331 ELSE IF( lsame( range, 'I' ) ) THEN
332 irange = 3
333 ELSE
334 irange = 0
335 END IF
336*
337* Decode ORDER
338*
339 IF( lsame( order, 'B' ) ) THEN
340 iorder = 2
341 ELSE IF( lsame( order, 'E' ) ) THEN
342 iorder = 1
343 ELSE
344 iorder = 0
345 END IF
346*
347* Check for Errors
348*
349 IF( irange.LE.0 ) THEN
350 info = -1
351 ELSE IF( iorder.LE.0 ) THEN
352 info = -2
353 ELSE IF( n.LT.0 ) THEN
354 info = -3
355 ELSE IF( irange.EQ.2 ) THEN
356 IF( vl.GE.vu )
357 $ info = -5
358 ELSE IF( irange.EQ.3 .AND. ( il.LT.1 .OR. il.GT.max( 1, n ) ) )
359 $ THEN
360 info = -6
361 ELSE IF( irange.EQ.3 .AND. ( iu.LT.min( n, il ) .OR. iu.GT.n ) )
362 $ THEN
363 info = -7
364 END IF
365*
366 IF( info.NE.0 ) THEN
367 CALL xerbla( 'DSTEBZ', -info )
368 RETURN
369 END IF
370*
371* Initialize error flags
372*
373 info = 0
374 ncnvrg = .false.
375 toofew = .false.
376*
377* Quick return if possible
378*
379 m = 0
380 IF( n.EQ.0 )
381 $ RETURN
382*
383* Simplifications:
384*
385 IF( irange.EQ.3 .AND. il.EQ.1 .AND. iu.EQ.n )
386 $ irange = 1
387*
388* Get machine constants
389* NB is the minimum vector length for vector bisection, or 0
390* if only scalar is to be done.
391*
392 safemn = dlamch( 'S' )
393 ulp = dlamch( 'P' )
394 rtoli = ulp*relfac
395 nb = ilaenv( 1, 'DSTEBZ', ' ', n, -1, -1, -1 )
396 IF( nb.LE.1 )
397 $ nb = 0
398*
399* Special Case when N=1
400*
401 IF( n.EQ.1 ) THEN
402 nsplit = 1
403 isplit( 1 ) = 1
404 IF( irange.EQ.2 .AND. ( vl.GE.d( 1 ) .OR. vu.LT.d( 1 ) ) ) THEN
405 m = 0
406 ELSE
407 w( 1 ) = d( 1 )
408 iblock( 1 ) = 1
409 m = 1
410 END IF
411 RETURN
412 END IF
413*
414* Compute Splitting Points
415*
416 nsplit = 1
417 work( n ) = zero
418 pivmin = one
419*
420 DO 10 j = 2, n
421 tmp1 = e( j-1 )**2
422 IF( abs( d( j )*d( j-1 ) )*ulp**2+safemn.GT.tmp1 ) THEN
423 isplit( nsplit ) = j - 1
424 nsplit = nsplit + 1
425 work( j-1 ) = zero
426 ELSE
427 work( j-1 ) = tmp1
428 pivmin = max( pivmin, tmp1 )
429 END IF
430 10 CONTINUE
431 isplit( nsplit ) = n
432 pivmin = pivmin*safemn
433*
434* Compute Interval and ATOLI
435*
436 IF( irange.EQ.3 ) THEN
437*
438* RANGE='I': Compute the interval containing eigenvalues
439* IL through IU.
440*
441* Compute Gershgorin interval for entire (split) matrix
442* and use it as the initial interval
443*
444 gu = d( 1 )
445 gl = d( 1 )
446 tmp1 = zero
447*
448 DO 20 j = 1, n - 1
449 tmp2 = sqrt( work( j ) )
450 gu = max( gu, d( j )+tmp1+tmp2 )
451 gl = min( gl, d( j )-tmp1-tmp2 )
452 tmp1 = tmp2
453 20 CONTINUE
454*
455 gu = max( gu, d( n )+tmp1 )
456 gl = min( gl, d( n )-tmp1 )
457 tnorm = max( abs( gl ), abs( gu ) )
458 gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin
459 gu = gu + fudge*tnorm*ulp*n + fudge*pivmin
460*
461* Compute Iteration parameters
462*
463 itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
464 $ log( two ) ) + 2
465 IF( abstol.LE.zero ) THEN
466 atoli = ulp*tnorm
467 ELSE
468 atoli = abstol
469 END IF
470*
471 work( n+1 ) = gl
472 work( n+2 ) = gl
473 work( n+3 ) = gu
474 work( n+4 ) = gu
475 work( n+5 ) = gl
476 work( n+6 ) = gu
477 iwork( 1 ) = -1
478 iwork( 2 ) = -1
479 iwork( 3 ) = n + 1
480 iwork( 4 ) = n + 1
481 iwork( 5 ) = il - 1
482 iwork( 6 ) = iu
483*
484 CALL dlaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin, d, e,
485 $ work, iwork( 5 ), work( n+1 ), work( n+5 ), iout,
486 $ iwork, w, iblock, iinfo )
487*
488 IF( iwork( 6 ).EQ.iu ) THEN
489 wl = work( n+1 )
490 wlu = work( n+3 )
491 nwl = iwork( 1 )
492 wu = work( n+4 )
493 wul = work( n+2 )
494 nwu = iwork( 4 )
495 ELSE
496 wl = work( n+2 )
497 wlu = work( n+4 )
498 nwl = iwork( 2 )
499 wu = work( n+3 )
500 wul = work( n+1 )
501 nwu = iwork( 3 )
502 END IF
503*
504 IF( nwl.LT.0 .OR. nwl.GE.n .OR. nwu.LT.1 .OR. nwu.GT.n ) THEN
505 info = 4
506 RETURN
507 END IF
508 ELSE
509*
510* RANGE='A' or 'V' -- Set ATOLI
511*
512 tnorm = max( abs( d( 1 ) )+abs( e( 1 ) ),
513 $ abs( d( n ) )+abs( e( n-1 ) ) )
514*
515 DO 30 j = 2, n - 1
516 tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+
517 $ abs( e( j ) ) )
518 30 CONTINUE
519*
520 IF( abstol.LE.zero ) THEN
521 atoli = ulp*tnorm
522 ELSE
523 atoli = abstol
524 END IF
525*
526 IF( irange.EQ.2 ) THEN
527 wl = vl
528 wu = vu
529 ELSE
530 wl = zero
531 wu = zero
532 END IF
533 END IF
534*
535* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
536* NWL accumulates the number of eigenvalues .le. WL,
537* NWU accumulates the number of eigenvalues .le. WU
538*
539 m = 0
540 iend = 0
541 info = 0
542 nwl = 0
543 nwu = 0
544*
545 DO 70 jb = 1, nsplit
546 ioff = iend
547 ibegin = ioff + 1
548 iend = isplit( jb )
549 in = iend - ioff
550*
551 IF( in.EQ.1 ) THEN
552*
553* Special Case -- IN=1
554*
555 IF( irange.EQ.1 .OR. wl.GE.d( ibegin )-pivmin )
556 $ nwl = nwl + 1
557 IF( irange.EQ.1 .OR. wu.GE.d( ibegin )-pivmin )
558 $ nwu = nwu + 1
559 IF( irange.EQ.1 .OR. ( wl.LT.d( ibegin )-pivmin .AND. wu.GE.
560 $ d( ibegin )-pivmin ) ) THEN
561 m = m + 1
562 w( m ) = d( ibegin )
563 iblock( m ) = jb
564 END IF
565 ELSE
566*
567* General Case -- IN > 1
568*
569* Compute Gershgorin Interval
570* and use it as the initial interval
571*
572 gu = d( ibegin )
573 gl = d( ibegin )
574 tmp1 = zero
575*
576 DO 40 j = ibegin, iend - 1
577 tmp2 = abs( e( j ) )
578 gu = max( gu, d( j )+tmp1+tmp2 )
579 gl = min( gl, d( j )-tmp1-tmp2 )
580 tmp1 = tmp2
581 40 CONTINUE
582*
583 gu = max( gu, d( iend )+tmp1 )
584 gl = min( gl, d( iend )-tmp1 )
585 bnorm = max( abs( gl ), abs( gu ) )
586 gl = gl - fudge*bnorm*ulp*in - fudge*pivmin
587 gu = gu + fudge*bnorm*ulp*in + fudge*pivmin
588*
589* Compute ATOLI for the current submatrix
590*
591 IF( abstol.LE.zero ) THEN
592 atoli = ulp*max( abs( gl ), abs( gu ) )
593 ELSE
594 atoli = abstol
595 END IF
596*
597 IF( irange.GT.1 ) THEN
598 IF( gu.LT.wl ) THEN
599 nwl = nwl + in
600 nwu = nwu + in
601 GO TO 70
602 END IF
603 gl = max( gl, wl )
604 gu = min( gu, wu )
605 IF( gl.GE.gu )
606 $ GO TO 70
607 END IF
608*
609* Set Up Initial Interval
610*
611 work( n+1 ) = gl
612 work( n+in+1 ) = gu
613 CALL dlaebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,
614 $ d( ibegin ), e( ibegin ), work( ibegin ),
615 $ idumma, work( n+1 ), work( n+2*in+1 ), im,
616 $ iwork, w( m+1 ), iblock( m+1 ), iinfo )
617*
618 nwl = nwl + iwork( 1 )
619 nwu = nwu + iwork( in+1 )
620 iwoff = m - iwork( 1 )
621*
622* Compute Eigenvalues
623*
624 itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /
625 $ log( two ) ) + 2
626 CALL dlaebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,
627 $ d( ibegin ), e( ibegin ), work( ibegin ),
628 $ idumma, work( n+1 ), work( n+2*in+1 ), iout,
629 $ iwork, w( m+1 ), iblock( m+1 ), iinfo )
630*
631* Copy Eigenvalues Into W and IBLOCK
632* Use -JB for block number for unconverged eigenvalues.
633*
634 DO 60 j = 1, iout
635 tmp1 = half*( work( j+n )+work( j+in+n ) )
636*
637* Flag non-convergence.
638*
639 IF( j.GT.iout-iinfo ) THEN
640 ncnvrg = .true.
641 ib = -jb
642 ELSE
643 ib = jb
644 END IF
645 DO 50 je = iwork( j ) + 1 + iwoff,
646 $ iwork( j+in ) + iwoff
647 w( je ) = tmp1
648 iblock( je ) = ib
649 50 CONTINUE
650 60 CONTINUE
651*
652 m = m + im
653 END IF
654 70 CONTINUE
655*
656* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
657* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
658*
659 IF( irange.EQ.3 ) THEN
660 im = 0
661 idiscl = il - 1 - nwl
662 idiscu = nwu - iu
663*
664 IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
665 DO 80 je = 1, m
666 IF( w( je ).LE.wlu .AND. idiscl.GT.0 ) THEN
667 idiscl = idiscl - 1
668 ELSE IF( w( je ).GE.wul .AND. idiscu.GT.0 ) THEN
669 idiscu = idiscu - 1
670 ELSE
671 im = im + 1
672 w( im ) = w( je )
673 iblock( im ) = iblock( je )
674 END IF
675 80 CONTINUE
676 m = im
677 END IF
678 IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
679*
680* Code to deal with effects of bad arithmetic:
681* Some low eigenvalues to be discarded are not in (WL,WLU],
682* or high eigenvalues to be discarded are not in (WUL,WU]
683* so just kill off the smallest IDISCL/largest IDISCU
684* eigenvalues, by simply finding the smallest/largest
685* eigenvalue(s).
686*
687* (If N(w) is monotone non-decreasing, this should never
688* happen.)
689*
690 IF( idiscl.GT.0 ) THEN
691 wkill = wu
692 DO 100 jdisc = 1, idiscl
693 iw = 0
694 DO 90 je = 1, m
695 IF( iblock( je ).NE.0 .AND.
696 $ ( w( je ).LT.wkill .OR. iw.EQ.0 ) ) THEN
697 iw = je
698 wkill = w( je )
699 END IF
700 90 CONTINUE
701 iblock( iw ) = 0
702 100 CONTINUE
703 END IF
704 IF( idiscu.GT.0 ) THEN
705*
706 wkill = wl
707 DO 120 jdisc = 1, idiscu
708 iw = 0
709 DO 110 je = 1, m
710 IF( iblock( je ).NE.0 .AND.
711 $ ( w( je ).GT.wkill .OR. iw.EQ.0 ) ) THEN
712 iw = je
713 wkill = w( je )
714 END IF
715 110 CONTINUE
716 iblock( iw ) = 0
717 120 CONTINUE
718 END IF
719 im = 0
720 DO 130 je = 1, m
721 IF( iblock( je ).NE.0 ) THEN
722 im = im + 1
723 w( im ) = w( je )
724 iblock( im ) = iblock( je )
725 END IF
726 130 CONTINUE
727 m = im
728 END IF
729 IF( idiscl.LT.0 .OR. idiscu.LT.0 ) THEN
730 toofew = .true.
731 END IF
732 END IF
733*
734* If ORDER='B', do nothing -- the eigenvalues are already sorted
735* by block.
736* If ORDER='E', sort the eigenvalues from smallest to largest
737*
738 IF( iorder.EQ.1 .AND. nsplit.GT.1 ) THEN
739 DO 150 je = 1, m - 1
740 ie = 0
741 tmp1 = w( je )
742 DO 140 j = je + 1, m
743 IF( w( j ).LT.tmp1 ) THEN
744 ie = j
745 tmp1 = w( j )
746 END IF
747 140 CONTINUE
748*
749 IF( ie.NE.0 ) THEN
750 itmp1 = iblock( ie )
751 w( ie ) = w( je )
752 iblock( ie ) = iblock( je )
753 w( je ) = tmp1
754 iblock( je ) = itmp1
755 END IF
756 150 CONTINUE
757 END IF
758*
759 info = 0
760 IF( ncnvrg )
761 $ info = info + 1
762 IF( toofew )
763 $ info = info + 2
764 RETURN
765*
766* End of DSTEBZ
767*
dlaebz
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 ...
Definition dlaebz.f:319

◆ dstedc()

subroutine dstedc ( character compz,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

DSTEDC

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

Purpose:
!>
!> DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!> symmetric tridiagonal matrix using the divide and conquer method.
!> The eigenvectors of a full or band real symmetric matrix can also be
!> found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
!> matrix to tridiagonal form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See DLAED3 for details.
!>
Parameters
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'I':  Compute eigenvectors of tridiagonal matrix also.
!>          = 'V':  Compute eigenvectors of original dense symmetric
!>                  matrix also.  On entry, Z contains the orthogonal
!>                  matrix used to reduce the original matrix to
!>                  tridiagonal form.
!>
[in]N
!>          N is INTEGER
!>          The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the subdiagonal elements of the tridiagonal matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
!>          On entry, if COMPZ = 'V', then Z contains the orthogonal
!>          matrix used in the reduction to tridiagonal form.
!>          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
!>          orthonormal eigenvectors of the original symmetric matrix,
!>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!>          of the symmetric tridiagonal matrix.
!>          If  COMPZ = 'N', then Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If eigenvectors are desired, then LDZ >= max(1,N).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
!>          If COMPZ = 'V' and N > 1 then LWORK must be at least
!>                         ( 1 + 3*N + 2*N*lg N + 4*N**2 ),
!>                         where lg( N ) = smallest integer k such
!>                         that 2**k >= N.
!>          If COMPZ = 'I' and N > 1 then LWORK must be at least
!>                         ( 1 + 4*N + N**2 ).
!>          Note that for COMPZ = 'I' or 'V', then if N is less than or
!>          equal to the minimum divide size, usually 25, then LWORK need
!>          only be max(1,2*(N-1)).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.
!>          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
!>          If COMPZ = 'V' and N > 1 then LIWORK must be at least
!>                         ( 6 + 6*N + 5*N*lg N ).
!>          If COMPZ = 'I' and N > 1 then LIWORK must be at least
!>                         ( 3 + 5*N ).
!>          Note that for COMPZ = 'I' or 'V', then if N is less than or
!>          equal to the minimum divide size, usually 25, then LIWORK
!>          need only be 1.
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 186 of file dstedc.f.

188*
189* -- LAPACK computational routine --
190* -- LAPACK is a software package provided by Univ. of Tennessee, --
191* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
192*
193* .. Scalar Arguments ..
194 CHARACTER COMPZ
195 INTEGER INFO, LDZ, LIWORK, LWORK, N
196* ..
197* .. Array Arguments ..
198 INTEGER IWORK( * )
199 DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
200* ..
201*
202* =====================================================================
203*
204* .. Parameters ..
205 DOUBLE PRECISION ZERO, ONE, TWO
206 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
207* ..
208* .. Local Scalars ..
209 LOGICAL LQUERY
210 INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
211 $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
212 DOUBLE PRECISION EPS, ORGNRM, P, TINY
213* ..
214* .. External Functions ..
215 LOGICAL LSAME
216 INTEGER ILAENV
217 DOUBLE PRECISION DLAMCH, DLANST
218 EXTERNAL lsame, ilaenv, dlamch, dlanst
219* ..
220* .. External Subroutines ..
221 EXTERNAL dgemm, dlacpy, dlaed0, dlascl, dlaset, dlasrt,
222 $ dsteqr, dsterf, dswap, xerbla
223* ..
224* .. Intrinsic Functions ..
225 INTRINSIC abs, dble, int, log, max, mod, sqrt
226* ..
227* .. Executable Statements ..
228*
229* Test the input parameters.
230*
231 info = 0
232 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
233*
234 IF( lsame( compz, 'N' ) ) THEN
235 icompz = 0
236 ELSE IF( lsame( compz, 'V' ) ) THEN
237 icompz = 1
238 ELSE IF( lsame( compz, 'I' ) ) THEN
239 icompz = 2
240 ELSE
241 icompz = -1
242 END IF
243 IF( icompz.LT.0 ) THEN
244 info = -1
245 ELSE IF( n.LT.0 ) THEN
246 info = -2
247 ELSE IF( ( ldz.LT.1 ) .OR.
248 $ ( icompz.GT.0 .AND. ldz.LT.max( 1, n ) ) ) THEN
249 info = -6
250 END IF
251*
252 IF( info.EQ.0 ) THEN
253*
254* Compute the workspace requirements
255*
256 smlsiz = ilaenv( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
257 IF( n.LE.1 .OR. icompz.EQ.0 ) THEN
258 liwmin = 1
259 lwmin = 1
260 ELSE IF( n.LE.smlsiz ) THEN
261 liwmin = 1
262 lwmin = 2*( n - 1 )
263 ELSE
264 lgn = int( log( dble( n ) )/log( two ) )
265 IF( 2**lgn.LT.n )
266 $ lgn = lgn + 1
267 IF( 2**lgn.LT.n )
268 $ lgn = lgn + 1
269 IF( icompz.EQ.1 ) THEN
270 lwmin = 1 + 3*n + 2*n*lgn + 4*n**2
271 liwmin = 6 + 6*n + 5*n*lgn
272 ELSE IF( icompz.EQ.2 ) THEN
273 lwmin = 1 + 4*n + n**2
274 liwmin = 3 + 5*n
275 END IF
276 END IF
277 work( 1 ) = lwmin
278 iwork( 1 ) = liwmin
279*
280 IF( lwork.LT.lwmin .AND. .NOT. lquery ) THEN
281 info = -8
282 ELSE IF( liwork.LT.liwmin .AND. .NOT. lquery ) THEN
283 info = -10
284 END IF
285 END IF
286*
287 IF( info.NE.0 ) THEN
288 CALL xerbla( 'DSTEDC', -info )
289 RETURN
290 ELSE IF (lquery) THEN
291 RETURN
292 END IF
293*
294* Quick return if possible
295*
296 IF( n.EQ.0 )
297 $ RETURN
298 IF( n.EQ.1 ) THEN
299 IF( icompz.NE.0 )
300 $ z( 1, 1 ) = one
301 RETURN
302 END IF
303*
304* If the following conditional clause is removed, then the routine
305* will use the Divide and Conquer routine to compute only the
306* eigenvalues, which requires (3N + 3N**2) real workspace and
307* (2 + 5N + 2N lg(N)) integer workspace.
308* Since on many architectures DSTERF is much faster than any other
309* algorithm for finding eigenvalues only, it is used here
310* as the default. If the conditional clause is removed, then
311* information on the size of workspace needs to be changed.
312*
313* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
314*
315 IF( icompz.EQ.0 ) THEN
316 CALL dsterf( n, d, e, info )
317 GO TO 50
318 END IF
319*
320* If N is smaller than the minimum divide size (SMLSIZ+1), then
321* solve the problem with another solver.
322*
323 IF( n.LE.smlsiz ) THEN
324*
325 CALL dsteqr( compz, n, d, e, z, ldz, work, info )
326*
327 ELSE
328*
329* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
330* use.
331*
332 IF( icompz.EQ.1 ) THEN
333 storez = 1 + n*n
334 ELSE
335 storez = 1
336 END IF
337*
338 IF( icompz.EQ.2 ) THEN
339 CALL dlaset( 'Full', n, n, zero, one, z, ldz )
340 END IF
341*
342* Scale.
343*
344 orgnrm = dlanst( 'M', n, d, e )
345 IF( orgnrm.EQ.zero )
346 $ GO TO 50
347*
348 eps = dlamch( 'Epsilon' )
349*
350 start = 1
351*
352* while ( START <= N )
353*
354 10 CONTINUE
355 IF( start.LE.n ) THEN
356*
357* Let FINISH be the position of the next subdiagonal entry
358* such that E( FINISH ) <= TINY or FINISH = N if no such
359* subdiagonal exists. The matrix identified by the elements
360* between START and FINISH constitutes an independent
361* sub-problem.
362*
363 finish = start
364 20 CONTINUE
365 IF( finish.LT.n ) THEN
366 tiny = eps*sqrt( abs( d( finish ) ) )*
367 $ sqrt( abs( d( finish+1 ) ) )
368 IF( abs( e( finish ) ).GT.tiny ) THEN
369 finish = finish + 1
370 GO TO 20
371 END IF
372 END IF
373*
374* (Sub) Problem determined. Compute its size and solve it.
375*
376 m = finish - start + 1
377 IF( m.EQ.1 ) THEN
378 start = finish + 1
379 GO TO 10
380 END IF
381 IF( m.GT.smlsiz ) THEN
382*
383* Scale.
384*
385 orgnrm = dlanst( 'M', m, d( start ), e( start ) )
386 CALL dlascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,
387 $ info )
388 CALL dlascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),
389 $ m-1, info )
390*
391 IF( icompz.EQ.1 ) THEN
392 strtrw = 1
393 ELSE
394 strtrw = start
395 END IF
396 CALL dlaed0( icompz, n, m, d( start ), e( start ),
397 $ z( strtrw, start ), ldz, work( 1 ), n,
398 $ work( storez ), iwork, info )
399 IF( info.NE.0 ) THEN
400 info = ( info / ( m+1 )+start-1 )*( n+1 ) +
401 $ mod( info, ( m+1 ) ) + start - 1
402 GO TO 50
403 END IF
404*
405* Scale back.
406*
407 CALL dlascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,
408 $ info )
409*
410 ELSE
411 IF( icompz.EQ.1 ) THEN
412*
413* Since QR won't update a Z matrix which is larger than
414* the length of D, we must solve the sub-problem in a
415* workspace and then multiply back into Z.
416*
417 CALL dsteqr( 'I', m, d( start ), e( start ), work, m,
418 $ work( m*m+1 ), info )
419 CALL dlacpy( 'A', n, m, z( 1, start ), ldz,
420 $ work( storez ), n )
421 CALL dgemm( 'N', 'N', n, m, m, one,
422 $ work( storez ), n, work, m, zero,
423 $ z( 1, start ), ldz )
424 ELSE IF( icompz.EQ.2 ) THEN
425 CALL dsteqr( 'I', m, d( start ), e( start ),
426 $ z( start, start ), ldz, work, info )
427 ELSE
428 CALL dsterf( m, d( start ), e( start ), info )
429 END IF
430 IF( info.NE.0 ) THEN
431 info = start*( n+1 ) + finish
432 GO TO 50
433 END IF
434 END IF
435*
436 start = finish + 1
437 GO TO 10
438 END IF
439*
440* endwhile
441*
442 IF( icompz.EQ.0 ) THEN
443*
444* Use Quick Sort
445*
446 CALL dlasrt( 'I', n, d, info )
447*
448 ELSE
449*
450* Use Selection Sort to minimize swaps of eigenvectors
451*
452 DO 40 ii = 2, n
453 i = ii - 1
454 k = i
455 p = d( i )
456 DO 30 j = ii, n
457 IF( d( j ).LT.p ) THEN
458 k = j
459 p = d( j )
460 END IF
461 30 CONTINUE
462 IF( k.NE.i ) THEN
463 d( k ) = d( i )
464 d( i ) = p
465 CALL dswap( n, z( 1, i ), 1, z( 1, k ), 1 )
466 END IF
467 40 CONTINUE
468 END IF
469 END IF
470*
471 50 CONTINUE
472 work( 1 ) = lwmin
473 iwork( 1 ) = liwmin
474*
475 RETURN
476*
477* End of DSTEDC
478*
dsterf
subroutine dsterf(n, d, e, info)
DSTERF
Definition dsterf.f:86
dlaed0
subroutine dlaed0(icompq, qsiz, n, d, e, q, ldq, qstore, ldqs, work, iwork, info)
DLAED0 used by DSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
Definition dlaed0.f:172

◆ dsteqr()

subroutine dsteqr ( character compz,
integer n,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) work,
integer info )

DSTEQR

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

Purpose:
!>
!> DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!> symmetric tridiagonal matrix using the implicit QL or QR method.
!> The eigenvectors of a full or band symmetric matrix can also be found
!> if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
!> tridiagonal form.
!>
Parameters
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'V':  Compute eigenvalues and eigenvectors of the original
!>                  symmetric matrix.  On entry, Z must contain the
!>                  orthogonal matrix used to reduce the original matrix
!>                  to tridiagonal form.
!>          = 'I':  Compute eigenvalues and eigenvectors of the
!>                  tridiagonal matrix.  Z is initialized to the identity
!>                  matrix.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>          On entry, if  COMPZ = 'V', then Z contains the orthogonal
!>          matrix used in the reduction to tridiagonal form.
!>          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
!>          orthonormal eigenvectors of the original symmetric matrix,
!>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!>          of the symmetric tridiagonal matrix.
!>          If COMPZ = 'N', then Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          eigenvectors are desired, then  LDZ >= max(1,N).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (max(1,2*N-2))
!>          If COMPZ = 'N', then WORK is not referenced.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm has failed to find all the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero; on exit, D
!>                and E contain the elements of a symmetric tridiagonal
!>                matrix which is orthogonally similar to the original
!>                matrix.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file dsteqr.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER COMPZ
138 INTEGER INFO, LDZ, N
139* ..
140* .. Array Arguments ..
141 DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 DOUBLE PRECISION ZERO, ONE, TWO, THREE
148 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
149 $ three = 3.0d0 )
150 INTEGER MAXIT
151 parameter( maxit = 30 )
152* ..
153* .. Local Scalars ..
154 INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
155 $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
156 $ NM1, NMAXIT
157 DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
158 $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
163 EXTERNAL lsame, dlamch, dlanst, dlapy2
164* ..
165* .. External Subroutines ..
166 EXTERNAL dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr,
167 $ dlasrt, dswap, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, sign, sqrt
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177*
178 IF( lsame( compz, 'N' ) ) THEN
179 icompz = 0
180 ELSE IF( lsame( compz, 'V' ) ) THEN
181 icompz = 1
182 ELSE IF( lsame( compz, 'I' ) ) THEN
183 icompz = 2
184 ELSE
185 icompz = -1
186 END IF
187 IF( icompz.LT.0 ) THEN
188 info = -1
189 ELSE IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( ( ldz.LT.1 ) .OR. ( icompz.GT.0 .AND. ldz.LT.max( 1,
192 $ n ) ) ) THEN
193 info = -6
194 END IF
195 IF( info.NE.0 ) THEN
196 CALL xerbla( 'DSTEQR', -info )
197 RETURN
198 END IF
199*
200* Quick return if possible
201*
202 IF( n.EQ.0 )
203 $ RETURN
204*
205 IF( n.EQ.1 ) THEN
206 IF( icompz.EQ.2 )
207 $ z( 1, 1 ) = one
208 RETURN
209 END IF
210*
211* Determine the unit roundoff and over/underflow thresholds.
212*
213 eps = dlamch( 'E' )
214 eps2 = eps**2
215 safmin = dlamch( 'S' )
216 safmax = one / safmin
217 ssfmax = sqrt( safmax ) / three
218 ssfmin = sqrt( safmin ) / eps2
219*
220* Compute the eigenvalues and eigenvectors of the tridiagonal
221* matrix.
222*
223 IF( icompz.EQ.2 )
224 $ CALL dlaset( 'Full', n, n, zero, one, z, ldz )
225*
226 nmaxit = n*maxit
227 jtot = 0
228*
229* Determine where the matrix splits and choose QL or QR iteration
230* for each block, according to whether top or bottom diagonal
231* element is smaller.
232*
233 l1 = 1
234 nm1 = n - 1
235*
236 10 CONTINUE
237 IF( l1.GT.n )
238 $ GO TO 160
239 IF( l1.GT.1 )
240 $ e( l1-1 ) = zero
241 IF( l1.LE.nm1 ) THEN
242 DO 20 m = l1, nm1
243 tst = abs( e( m ) )
244 IF( tst.EQ.zero )
245 $ GO TO 30
246 IF( tst.LE.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
247 $ 1 ) ) ) )*eps ) THEN
248 e( m ) = zero
249 GO TO 30
250 END IF
251 20 CONTINUE
252 END IF
253 m = n
254*
255 30 CONTINUE
256 l = l1
257 lsv = l
258 lend = m
259 lendsv = lend
260 l1 = m + 1
261 IF( lend.EQ.l )
262 $ GO TO 10
263*
264* Scale submatrix in rows and columns L to LEND
265*
266 anorm = dlanst( 'M', lend-l+1, d( l ), e( l ) )
267 iscale = 0
268 IF( anorm.EQ.zero )
269 $ GO TO 10
270 IF( anorm.GT.ssfmax ) THEN
271 iscale = 1
272 CALL dlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
273 $ info )
274 CALL dlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
275 $ info )
276 ELSE IF( anorm.LT.ssfmin ) THEN
277 iscale = 2
278 CALL dlascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
279 $ info )
280 CALL dlascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
281 $ info )
282 END IF
283*
284* Choose between QL and QR iteration
285*
286 IF( abs( d( lend ) ).LT.abs( d( l ) ) ) THEN
287 lend = lsv
288 l = lendsv
289 END IF
290*
291 IF( lend.GT.l ) THEN
292*
293* QL Iteration
294*
295* Look for small subdiagonal element.
296*
297 40 CONTINUE
298 IF( l.NE.lend ) THEN
299 lendm1 = lend - 1
300 DO 50 m = l, lendm1
301 tst = abs( e( m ) )**2
302 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+
303 $ safmin )GO TO 60
304 50 CONTINUE
305 END IF
306*
307 m = lend
308*
309 60 CONTINUE
310 IF( m.LT.lend )
311 $ e( m ) = zero
312 p = d( l )
313 IF( m.EQ.l )
314 $ GO TO 80
315*
316* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
317* to compute its eigensystem.
318*
319 IF( m.EQ.l+1 ) THEN
320 IF( icompz.GT.0 ) THEN
321 CALL dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
322 work( l ) = c
323 work( n-1+l ) = s
324 CALL dlasr( 'R', 'V', 'B', n, 2, work( l ),
325 $ work( n-1+l ), z( 1, l ), ldz )
326 ELSE
327 CALL dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
328 END IF
329 d( l ) = rt1
330 d( l+1 ) = rt2
331 e( l ) = zero
332 l = l + 2
333 IF( l.LE.lend )
334 $ GO TO 40
335 GO TO 140
336 END IF
337*
338 IF( jtot.EQ.nmaxit )
339 $ GO TO 140
340 jtot = jtot + 1
341*
342* Form shift.
343*
344 g = ( d( l+1 )-p ) / ( two*e( l ) )
345 r = dlapy2( g, one )
346 g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
347*
348 s = one
349 c = one
350 p = zero
351*
352* Inner loop
353*
354 mm1 = m - 1
355 DO 70 i = mm1, l, -1
356 f = s*e( i )
357 b = c*e( i )
358 CALL dlartg( g, f, c, s, r )
359 IF( i.NE.m-1 )
360 $ e( i+1 ) = r
361 g = d( i+1 ) - p
362 r = ( d( i )-g )*s + two*c*b
363 p = s*r
364 d( i+1 ) = g + p
365 g = c*r - b
366*
367* If eigenvectors are desired, then save rotations.
368*
369 IF( icompz.GT.0 ) THEN
370 work( i ) = c
371 work( n-1+i ) = -s
372 END IF
373*
374 70 CONTINUE
375*
376* If eigenvectors are desired, then apply saved rotations.
377*
378 IF( icompz.GT.0 ) THEN
379 mm = m - l + 1
380 CALL dlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),
381 $ z( 1, l ), ldz )
382 END IF
383*
384 d( l ) = d( l ) - p
385 e( l ) = g
386 GO TO 40
387*
388* Eigenvalue found.
389*
390 80 CONTINUE
391 d( l ) = p
392*
393 l = l + 1
394 IF( l.LE.lend )
395 $ GO TO 40
396 GO TO 140
397*
398 ELSE
399*
400* QR Iteration
401*
402* Look for small superdiagonal element.
403*
404 90 CONTINUE
405 IF( l.NE.lend ) THEN
406 lendp1 = lend + 1
407 DO 100 m = l, lendp1, -1
408 tst = abs( e( m-1 ) )**2
409 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+
410 $ safmin )GO TO 110
411 100 CONTINUE
412 END IF
413*
414 m = lend
415*
416 110 CONTINUE
417 IF( m.GT.lend )
418 $ e( m-1 ) = zero
419 p = d( l )
420 IF( m.EQ.l )
421 $ GO TO 130
422*
423* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
424* to compute its eigensystem.
425*
426 IF( m.EQ.l-1 ) THEN
427 IF( icompz.GT.0 ) THEN
428 CALL dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
429 work( m ) = c
430 work( n-1+m ) = s
431 CALL dlasr( 'R', 'V', 'F', n, 2, work( m ),
432 $ work( n-1+m ), z( 1, l-1 ), ldz )
433 ELSE
434 CALL dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
435 END IF
436 d( l-1 ) = rt1
437 d( l ) = rt2
438 e( l-1 ) = zero
439 l = l - 2
440 IF( l.GE.lend )
441 $ GO TO 90
442 GO TO 140
443 END IF
444*
445 IF( jtot.EQ.nmaxit )
446 $ GO TO 140
447 jtot = jtot + 1
448*
449* Form shift.
450*
451 g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
452 r = dlapy2( g, one )
453 g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
454*
455 s = one
456 c = one
457 p = zero
458*
459* Inner loop
460*
461 lm1 = l - 1
462 DO 120 i = m, lm1
463 f = s*e( i )
464 b = c*e( i )
465 CALL dlartg( g, f, c, s, r )
466 IF( i.NE.m )
467 $ e( i-1 ) = r
468 g = d( i ) - p
469 r = ( d( i+1 )-g )*s + two*c*b
470 p = s*r
471 d( i ) = g + p
472 g = c*r - b
473*
474* If eigenvectors are desired, then save rotations.
475*
476 IF( icompz.GT.0 ) THEN
477 work( i ) = c
478 work( n-1+i ) = s
479 END IF
480*
481 120 CONTINUE
482*
483* If eigenvectors are desired, then apply saved rotations.
484*
485 IF( icompz.GT.0 ) THEN
486 mm = l - m + 1
487 CALL dlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),
488 $ z( 1, m ), ldz )
489 END IF
490*
491 d( l ) = d( l ) - p
492 e( lm1 ) = g
493 GO TO 90
494*
495* Eigenvalue found.
496*
497 130 CONTINUE
498 d( l ) = p
499*
500 l = l - 1
501 IF( l.GE.lend )
502 $ GO TO 90
503 GO TO 140
504*
505 END IF
506*
507* Undo scaling if necessary
508*
509 140 CONTINUE
510 IF( iscale.EQ.1 ) THEN
511 CALL dlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
512 $ d( lsv ), n, info )
513 CALL dlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
514 $ n, info )
515 ELSE IF( iscale.EQ.2 ) THEN
516 CALL dlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
517 $ d( lsv ), n, info )
518 CALL dlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),
519 $ n, info )
520 END IF
521*
522* Check for no convergence to an eigenvalue after a total
523* of N*MAXIT iterations.
524*
525 IF( jtot.LT.nmaxit )
526 $ GO TO 10
527 DO 150 i = 1, n - 1
528 IF( e( i ).NE.zero )
529 $ info = info + 1
530 150 CONTINUE
531 GO TO 190
532*
533* Order eigenvalues and eigenvectors.
534*
535 160 CONTINUE
536 IF( icompz.EQ.0 ) THEN
537*
538* Use Quick Sort
539*
540 CALL dlasrt( 'I', n, d, info )
541*
542 ELSE
543*
544* Use Selection Sort to minimize swaps of eigenvectors
545*
546 DO 180 ii = 2, n
547 i = ii - 1
548 k = i
549 p = d( i )
550 DO 170 j = ii, n
551 IF( d( j ).LT.p ) THEN
552 k = j
553 p = d( j )
554 END IF
555 170 CONTINUE
556 IF( k.NE.i ) THEN
557 d( k ) = d( i )
558 d( i ) = p
559 CALL dswap( n, z( 1, i ), 1, z( 1, k ), 1 )
560 END IF
561 180 CONTINUE
562 END IF
563*
564 190 CONTINUE
565 RETURN
566*
567* End of DSTEQR
568*
dlae2
subroutine dlae2(a, b, c, rt1, rt2)
DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
Definition dlae2.f:102
dlaev2
subroutine dlaev2(a, b, c, rt1, rt2, cs1, sn1)
DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition dlaev2.f:120

◆ dsterf()

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

DSTERF

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

Purpose:
!>
!> DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
!> using the Pal-Walker-Kahan variant of the QL or QR algorithm.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the n diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm failed to find all of the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 85 of file dsterf.f.

86*
87* -- LAPACK computational routine --
88* -- LAPACK is a software package provided by Univ. of Tennessee, --
89* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
90*
91* .. Scalar Arguments ..
92 INTEGER INFO, N
93* ..
94* .. Array Arguments ..
95 DOUBLE PRECISION D( * ), E( * )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 DOUBLE PRECISION ZERO, ONE, TWO, THREE
102 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
103 $ three = 3.0d0 )
104 INTEGER MAXIT
105 parameter( maxit = 30 )
106* ..
107* .. Local Scalars ..
108 INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
109 $ NMAXIT
110 DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
111 $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
112 $ SIGMA, SSFMAX, SSFMIN, RMAX
113* ..
114* .. External Functions ..
115 DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
116 EXTERNAL dlamch, dlanst, dlapy2
117* ..
118* .. External Subroutines ..
119 EXTERNAL dlae2, dlascl, dlasrt, xerbla
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Test the input parameters.
127*
128 info = 0
129*
130* Quick return if possible
131*
132 IF( n.LT.0 ) THEN
133 info = -1
134 CALL xerbla( 'DSTERF', -info )
135 RETURN
136 END IF
137 IF( n.LE.1 )
138 $ RETURN
139*
140* Determine the unit roundoff for this environment.
141*
142 eps = dlamch( 'E' )
143 eps2 = eps**2
144 safmin = dlamch( 'S' )
145 safmax = one / safmin
146 ssfmax = sqrt( safmax ) / three
147 ssfmin = sqrt( safmin ) / eps2
148 rmax = dlamch( 'O' )
149*
150* Compute the eigenvalues of the tridiagonal matrix.
151*
152 nmaxit = n*maxit
153 sigma = zero
154 jtot = 0
155*
156* Determine where the matrix splits and choose QL or QR iteration
157* for each block, according to whether top or bottom diagonal
158* element is smaller.
159*
160 l1 = 1
161*
162 10 CONTINUE
163 IF( l1.GT.n )
164 $ GO TO 170
165 IF( l1.GT.1 )
166 $ e( l1-1 ) = zero
167 DO 20 m = l1, n - 1
168 IF( abs( e( m ) ).LE.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
169 $ 1 ) ) ) )*eps ) THEN
170 e( m ) = zero
171 GO TO 30
172 END IF
173 20 CONTINUE
174 m = n
175*
176 30 CONTINUE
177 l = l1
178 lsv = l
179 lend = m
180 lendsv = lend
181 l1 = m + 1
182 IF( lend.EQ.l )
183 $ GO TO 10
184*
185* Scale submatrix in rows and columns L to LEND
186*
187 anorm = dlanst( 'M', lend-l+1, d( l ), e( l ) )
188 iscale = 0
189 IF( anorm.EQ.zero )
190 $ GO TO 10
191 IF( (anorm.GT.ssfmax) ) THEN
192 iscale = 1
193 CALL dlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
194 $ info )
195 CALL dlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
196 $ info )
197 ELSE IF( anorm.LT.ssfmin ) THEN
198 iscale = 2
199 CALL dlascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
200 $ info )
201 CALL dlascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
202 $ info )
203 END IF
204*
205 DO 40 i = l, lend - 1
206 e( i ) = e( i )**2
207 40 CONTINUE
208*
209* Choose between QL and QR iteration
210*
211 IF( abs( d( lend ) ).LT.abs( d( l ) ) ) THEN
212 lend = lsv
213 l = lendsv
214 END IF
215*
216 IF( lend.GE.l ) THEN
217*
218* QL Iteration
219*
220* Look for small subdiagonal element.
221*
222 50 CONTINUE
223 IF( l.NE.lend ) THEN
224 DO 60 m = l, lend - 1
225 IF( abs( e( m ) ).LE.eps2*abs( d( m )*d( m+1 ) ) )
226 $ GO TO 70
227 60 CONTINUE
228 END IF
229 m = lend
230*
231 70 CONTINUE
232 IF( m.LT.lend )
233 $ e( m ) = zero
234 p = d( l )
235 IF( m.EQ.l )
236 $ GO TO 90
237*
238* If remaining matrix is 2 by 2, use DLAE2 to compute its
239* eigenvalues.
240*
241 IF( m.EQ.l+1 ) THEN
242 rte = sqrt( e( l ) )
243 CALL dlae2( d( l ), rte, d( l+1 ), rt1, rt2 )
244 d( l ) = rt1
245 d( l+1 ) = rt2
246 e( l ) = zero
247 l = l + 2
248 IF( l.LE.lend )
249 $ GO TO 50
250 GO TO 150
251 END IF
252*
253 IF( jtot.EQ.nmaxit )
254 $ GO TO 150
255 jtot = jtot + 1
256*
257* Form shift.
258*
259 rte = sqrt( e( l ) )
260 sigma = ( d( l+1 )-p ) / ( two*rte )
261 r = dlapy2( sigma, one )
262 sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
263*
264 c = one
265 s = zero
266 gamma = d( m ) - sigma
267 p = gamma*gamma
268*
269* Inner loop
270*
271 DO 80 i = m - 1, l, -1
272 bb = e( i )
273 r = p + bb
274 IF( i.NE.m-1 )
275 $ e( i+1 ) = s*r
276 oldc = c
277 c = p / r
278 s = bb / r
279 oldgam = gamma
280 alpha = d( i )
281 gamma = c*( alpha-sigma ) - s*oldgam
282 d( i+1 ) = oldgam + ( alpha-gamma )
283 IF( c.NE.zero ) THEN
284 p = ( gamma*gamma ) / c
285 ELSE
286 p = oldc*bb
287 END IF
288 80 CONTINUE
289*
290 e( l ) = s*p
291 d( l ) = sigma + gamma
292 GO TO 50
293*
294* Eigenvalue found.
295*
296 90 CONTINUE
297 d( l ) = p
298*
299 l = l + 1
300 IF( l.LE.lend )
301 $ GO TO 50
302 GO TO 150
303*
304 ELSE
305*
306* QR Iteration
307*
308* Look for small superdiagonal element.
309*
310 100 CONTINUE
311 DO 110 m = l, lend + 1, -1
312 IF( abs( e( m-1 ) ).LE.eps2*abs( d( m )*d( m-1 ) ) )
313 $ GO TO 120
314 110 CONTINUE
315 m = lend
316*
317 120 CONTINUE
318 IF( m.GT.lend )
319 $ e( m-1 ) = zero
320 p = d( l )
321 IF( m.EQ.l )
322 $ GO TO 140
323*
324* If remaining matrix is 2 by 2, use DLAE2 to compute its
325* eigenvalues.
326*
327 IF( m.EQ.l-1 ) THEN
328 rte = sqrt( e( l-1 ) )
329 CALL dlae2( d( l ), rte, d( l-1 ), rt1, rt2 )
330 d( l ) = rt1
331 d( l-1 ) = rt2
332 e( l-1 ) = zero
333 l = l - 2
334 IF( l.GE.lend )
335 $ GO TO 100
336 GO TO 150
337 END IF
338*
339 IF( jtot.EQ.nmaxit )
340 $ GO TO 150
341 jtot = jtot + 1
342*
343* Form shift.
344*
345 rte = sqrt( e( l-1 ) )
346 sigma = ( d( l-1 )-p ) / ( two*rte )
347 r = dlapy2( sigma, one )
348 sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
349*
350 c = one
351 s = zero
352 gamma = d( m ) - sigma
353 p = gamma*gamma
354*
355* Inner loop
356*
357 DO 130 i = m, l - 1
358 bb = e( i )
359 r = p + bb
360 IF( i.NE.m )
361 $ e( i-1 ) = s*r
362 oldc = c
363 c = p / r
364 s = bb / r
365 oldgam = gamma
366 alpha = d( i+1 )
367 gamma = c*( alpha-sigma ) - s*oldgam
368 d( i ) = oldgam + ( alpha-gamma )
369 IF( c.NE.zero ) THEN
370 p = ( gamma*gamma ) / c
371 ELSE
372 p = oldc*bb
373 END IF
374 130 CONTINUE
375*
376 e( l-1 ) = s*p
377 d( l ) = sigma + gamma
378 GO TO 100
379*
380* Eigenvalue found.
381*
382 140 CONTINUE
383 d( l ) = p
384*
385 l = l - 1
386 IF( l.GE.lend )
387 $ GO TO 100
388 GO TO 150
389*
390 END IF
391*
392* Undo scaling if necessary
393*
394 150 CONTINUE
395 IF( iscale.EQ.1 )
396 $ CALL dlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
397 $ d( lsv ), n, info )
398 IF( iscale.EQ.2 )
399 $ CALL dlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
400 $ d( lsv ), n, info )
401*
402* Check for no convergence to an eigenvalue after a total
403* of N*MAXIT iterations.
404*
405 IF( jtot.LT.nmaxit )
406 $ GO TO 10
407 DO 160 i = 1, n - 1
408 IF( e( i ).NE.zero )
409 $ info = info + 1
410 160 CONTINUE
411 GO TO 180
412*
413* Sort eigenvalues in increasing order.
414*
415 170 CONTINUE
416 CALL dlasrt( 'I', n, d, info )
417*
418 180 CONTINUE
419 RETURN
420*
421* End of DSTERF
422*
alpha
#define alpha
Definition eval.h:35

◆ iladiag()

integer function iladiag ( character diag)

ILADIAG

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

Purpose:
!>
!> This subroutine translated from a character string specifying if a
!> matrix has unit diagonal or not to the relevant BLAST-specified
!> integer constant.
!>
!> ILADIAG returns an INTEGER.  If ILADIAG < 0, then the input is not a
!> character indicating a unit or non-unit diagonal.  Otherwise ILADIAG
!> returns the constant value corresponding to DIAG.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file iladiag.f.

58*
59* -- LAPACK computational routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 CHARACTER DIAG
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER BLAS_NON_UNIT_DIAG, BLAS_UNIT_DIAG
71 parameter( blas_non_unit_diag = 131, blas_unit_diag = 132 )
72* ..
73* .. External Functions ..
74 LOGICAL LSAME
75 EXTERNAL lsame
76* ..
77* .. Executable Statements ..
78 IF( lsame( diag, 'N' ) ) THEN
79 iladiag = blas_non_unit_diag
80 ELSE IF( lsame( diag, 'U' ) ) THEN
81 iladiag = blas_unit_diag
82 ELSE
83 iladiag = -1
84 END IF
85 RETURN
86*
87* End of ILADIAG
88*
iladiag
integer function iladiag(diag)
ILADIAG
Definition iladiag.f:58

◆ ilaprec()

integer function ilaprec ( character prec)

ILAPREC

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

Purpose:
!>
!> This subroutine translated from a character string specifying an
!> intermediate precision to the relevant BLAST-specified integer
!> constant.
!>
!> ILAPREC returns an INTEGER.  If ILAPREC < 0, then the input is not a
!> character indicating a supported intermediate precision.  Otherwise
!> ILAPREC returns the constant value corresponding to PREC.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file ilaprec.f.

58*
59* -- LAPACK computational routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 CHARACTER PREC
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS,
71 $ BLAS_PREC_EXTRA
72 parameter( blas_prec_single = 211, blas_prec_double = 212,
73 $ blas_prec_indigenous = 213, blas_prec_extra = 214 )
74* ..
75* .. External Functions ..
76 LOGICAL LSAME
77 EXTERNAL lsame
78* ..
79* .. Executable Statements ..
80 IF( lsame( prec, 'S' ) ) THEN
81 ilaprec = blas_prec_single
82 ELSE IF( lsame( prec, 'D' ) ) THEN
83 ilaprec = blas_prec_double
84 ELSE IF( lsame( prec, 'I' ) ) THEN
85 ilaprec = blas_prec_indigenous
86 ELSE IF( lsame( prec, 'X' ) .OR. lsame( prec, 'E' ) ) THEN
87 ilaprec = blas_prec_extra
88 ELSE
89 ilaprec = -1
90 END IF
91 RETURN
92*
93* End of ILAPREC
94*
ilaprec
integer function ilaprec(prec)
ILAPREC
Definition ilaprec.f:58

◆ ilatrans()

integer function ilatrans ( character trans)

ILATRANS

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

Purpose:
!>
!> This subroutine translates from a character string specifying a
!> transposition operation to the relevant BLAST-specified integer
!> constant.
!>
!> ILATRANS returns an INTEGER.  If ILATRANS < 0, then the input is not
!> a character indicating a transposition operator.  Otherwise ILATRANS
!> returns the constant value corresponding to TRANS.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file ilatrans.f.

58*
59* -- LAPACK computational routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 CHARACTER TRANS
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS
71 parameter( blas_no_trans = 111, blas_trans = 112,
72 $ blas_conj_trans = 113 )
73* ..
74* .. External Functions ..
75 LOGICAL LSAME
76 EXTERNAL lsame
77* ..
78* .. Executable Statements ..
79 IF( lsame( trans, 'N' ) ) THEN
80 ilatrans = blas_no_trans
81 ELSE IF( lsame( trans, 'T' ) ) THEN
82 ilatrans = blas_trans
83 ELSE IF( lsame( trans, 'C' ) ) THEN
84 ilatrans = blas_conj_trans
85 ELSE
86 ilatrans = -1
87 END IF
88 RETURN
89*
90* End of ILATRANS
91*
ilatrans
integer function ilatrans(trans)
ILATRANS
Definition ilatrans.f:58

◆ ilauplo()

integer function ilauplo ( character uplo)

ILAUPLO

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

Purpose:
!>
!> This subroutine translated from a character string specifying a
!> upper- or lower-triangular matrix to the relevant BLAST-specified
!> integer constant.
!>
!> ILAUPLO returns an INTEGER.  If ILAUPLO < 0, then the input is not
!> a character indicating an upper- or lower-triangular matrix.
!> Otherwise ILAUPLO returns the constant value corresponding to UPLO.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 57 of file ilauplo.f.

58*
59* -- LAPACK computational routine --
60* -- LAPACK is a software package provided by Univ. of Tennessee, --
61* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
62*
63* .. Scalar Arguments ..
64 CHARACTER UPLO
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER BLAS_UPPER, BLAS_LOWER
71 parameter( blas_upper = 121, blas_lower = 122 )
72* ..
73* .. External Functions ..
74 LOGICAL LSAME
75 EXTERNAL lsame
76* ..
77* .. Executable Statements ..
78 IF( lsame( uplo, 'U' ) ) THEN
79 ilauplo = blas_upper
80 ELSE IF( lsame( uplo, 'L' ) ) THEN
81 ilauplo = blas_lower
82 ELSE
83 ilauplo = -1
84 END IF
85 RETURN
86*
87* End of ILAUPLO
88*
ilauplo
integer function ilauplo(uplo)
ILAUPLO
Definition ilauplo.f:58

◆ sbdsdc()

subroutine sbdsdc ( character uplo,
character compq,
integer n,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldu, * ) u,
integer ldu,
real, dimension( ldvt, * ) vt,
integer ldvt,
real, dimension( * ) q,
integer, dimension( * ) iq,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SBDSDC

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

Purpose:
!>
!> SBDSDC computes the singular value decomposition (SVD) of a real
!> N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
!> using a divide and conquer method, where S is a diagonal matrix
!> with non-negative diagonal elements (the singular values of B), and
!> U and VT are orthogonal matrices of left and right singular vectors,
!> respectively. SBDSDC can be used to compute all singular values,
!> and optionally, singular vectors or singular vectors in compact form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See SLASD3 for details.
!>
!> The code currently calls SLASDQ if singular values only are desired.
!> However, it can be slightly modified to compute singular values
!> using the divide and conquer method.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal.
!>          = 'L':  B is lower bidiagonal.
!>
[in]COMPQ
!>          COMPQ is CHARACTER*1
!>          Specifies whether singular vectors are to be computed
!>          as follows:
!>          = 'N':  Compute singular values only;
!>          = 'P':  Compute singular values and compute singular
!>                  vectors in compact form;
!>          = 'I':  Compute singular values and singular vectors.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the elements of E contain the offdiagonal
!>          elements of the bidiagonal matrix whose SVD is desired.
!>          On exit, E has been destroyed.
!>
[out]U
!>          U is REAL array, dimension (LDU,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, U contains the left singular vectors
!>             of the bidiagonal matrix.
!>          For other values of COMPQ, U is not referenced.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1.
!>          If singular vectors are desired, then LDU >= max( 1, N ).
!>
[out]VT
!>          VT is REAL array, dimension (LDVT,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, VT**T contains the right singular
!>             vectors of the bidiagonal matrix.
!>          For other values of COMPQ, VT is not referenced.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1.
!>          If singular vectors are desired, then LDVT >= max( 1, N ).
!>
[out]Q
!>          Q is REAL array, dimension (LDQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, Q contains all the REAL data in
!>             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, Q is not referenced.
!>
[out]IQ
!>          IQ is INTEGER array, dimension (LDIQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, IQ contains all INTEGER data in
!>             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, IQ is not referenced.
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          If COMPQ = 'N' then LWORK >= (4 * N).
!>          If COMPQ = 'P' then LWORK >= (6 * N).
!>          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (8*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute a singular value.
!>                The update process of divide and conquer failed.
!>
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 203 of file sbdsdc.f.

205*
206* -- LAPACK computational routine --
207* -- LAPACK is a software package provided by Univ. of Tennessee, --
208* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
209*
210* .. Scalar Arguments ..
211 CHARACTER COMPQ, UPLO
212 INTEGER INFO, LDU, LDVT, N
213* ..
214* .. Array Arguments ..
215 INTEGER IQ( * ), IWORK( * )
216 REAL D( * ), E( * ), Q( * ), U( LDU, * ),
217 $ VT( LDVT, * ), WORK( * )
218* ..
219*
220* =====================================================================
221* Changed dimension statement in comment describing E from (N) to
222* (N-1). Sven, 17 Feb 05.
223* =====================================================================
224*
225* .. Parameters ..
226 REAL ZERO, ONE, TWO
227 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
228* ..
229* .. Local Scalars ..
230 INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
231 $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
232 $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
233 $ SMLSZP, SQRE, START, WSTART, Z
234 REAL CS, EPS, ORGNRM, P, R, SN
235* ..
236* .. External Functions ..
237 LOGICAL LSAME
238 INTEGER ILAENV
239 REAL SLAMCH, SLANST
240 EXTERNAL slamch, slanst, ilaenv, lsame
241* ..
242* .. External Subroutines ..
243 EXTERNAL scopy, slartg, slascl, slasd0, slasda, slasdq,
244 $ slaset, slasr, sswap, xerbla
245* ..
246* .. Intrinsic Functions ..
247 INTRINSIC real, abs, int, log, sign
248* ..
249* .. Executable Statements ..
250*
251* Test the input parameters.
252*
253 info = 0
254*
255 iuplo = 0
256 IF( lsame( uplo, 'U' ) )
257 $ iuplo = 1
258 IF( lsame( uplo, 'L' ) )
259 $ iuplo = 2
260 IF( lsame( compq, 'N' ) ) THEN
261 icompq = 0
262 ELSE IF( lsame( compq, 'P' ) ) THEN
263 icompq = 1
264 ELSE IF( lsame( compq, 'I' ) ) THEN
265 icompq = 2
266 ELSE
267 icompq = -1
268 END IF
269 IF( iuplo.EQ.0 ) THEN
270 info = -1
271 ELSE IF( icompq.LT.0 ) THEN
272 info = -2
273 ELSE IF( n.LT.0 ) THEN
274 info = -3
275 ELSE IF( ( ldu.LT.1 ) .OR. ( ( icompq.EQ.2 ) .AND. ( ldu.LT.
276 $ n ) ) ) THEN
277 info = -7
278 ELSE IF( ( ldvt.LT.1 ) .OR. ( ( icompq.EQ.2 ) .AND. ( ldvt.LT.
279 $ n ) ) ) THEN
280 info = -9
281 END IF
282 IF( info.NE.0 ) THEN
283 CALL xerbla( 'SBDSDC', -info )
284 RETURN
285 END IF
286*
287* Quick return if possible
288*
289 IF( n.EQ.0 )
290 $ RETURN
291 smlsiz = ilaenv( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
292 IF( n.EQ.1 ) THEN
293 IF( icompq.EQ.1 ) THEN
294 q( 1 ) = sign( one, d( 1 ) )
295 q( 1+smlsiz*n ) = one
296 ELSE IF( icompq.EQ.2 ) THEN
297 u( 1, 1 ) = sign( one, d( 1 ) )
298 vt( 1, 1 ) = one
299 END IF
300 d( 1 ) = abs( d( 1 ) )
301 RETURN
302 END IF
303 nm1 = n - 1
304*
305* If matrix lower bidiagonal, rotate to be upper bidiagonal
306* by applying Givens rotations on the left
307*
308 wstart = 1
309 qstart = 3
310 IF( icompq.EQ.1 ) THEN
311 CALL scopy( n, d, 1, q( 1 ), 1 )
312 CALL scopy( n-1, e, 1, q( n+1 ), 1 )
313 END IF
314 IF( iuplo.EQ.2 ) THEN
315 qstart = 5
316 IF( icompq .EQ. 2 ) wstart = 2*n - 1
317 DO 10 i = 1, n - 1
318 CALL slartg( d( i ), e( i ), cs, sn, r )
319 d( i ) = r
320 e( i ) = sn*d( i+1 )
321 d( i+1 ) = cs*d( i+1 )
322 IF( icompq.EQ.1 ) THEN
323 q( i+2*n ) = cs
324 q( i+3*n ) = sn
325 ELSE IF( icompq.EQ.2 ) THEN
326 work( i ) = cs
327 work( nm1+i ) = -sn
328 END IF
329 10 CONTINUE
330 END IF
331*
332* If ICOMPQ = 0, use SLASDQ to compute the singular values.
333*
334 IF( icompq.EQ.0 ) THEN
335* Ignore WSTART, instead using WORK( 1 ), since the two vectors
336* for CS and -SN above are added only if ICOMPQ == 2,
337* and adding them exceeds documented WORK size of 4*n.
338 CALL slasdq( 'U', 0, n, 0, 0, 0, d, e, vt, ldvt, u, ldu, u,
339 $ ldu, work( 1 ), info )
340 GO TO 40
341 END IF
342*
343* If N is smaller than the minimum divide size SMLSIZ, then solve
344* the problem with another solver.
345*
346 IF( n.LE.smlsiz ) THEN
347 IF( icompq.EQ.2 ) THEN
348 CALL slaset( 'A', n, n, zero, one, u, ldu )
349 CALL slaset( 'A', n, n, zero, one, vt, ldvt )
350 CALL slasdq( 'U', 0, n, n, n, 0, d, e, vt, ldvt, u, ldu, u,
351 $ ldu, work( wstart ), info )
352 ELSE IF( icompq.EQ.1 ) THEN
353 iu = 1
354 ivt = iu + n
355 CALL slaset( 'A', n, n, zero, one, q( iu+( qstart-1 )*n ),
356 $ n )
357 CALL slaset( 'A', n, n, zero, one, q( ivt+( qstart-1 )*n ),
358 $ n )
359 CALL slasdq( 'U', 0, n, n, n, 0, d, e,
360 $ q( ivt+( qstart-1 )*n ), n,
361 $ q( iu+( qstart-1 )*n ), n,
362 $ q( iu+( qstart-1 )*n ), n, work( wstart ),
363 $ info )
364 END IF
365 GO TO 40
366 END IF
367*
368 IF( icompq.EQ.2 ) THEN
369 CALL slaset( 'A', n, n, zero, one, u, ldu )
370 CALL slaset( 'A', n, n, zero, one, vt, ldvt )
371 END IF
372*
373* Scale.
374*
375 orgnrm = slanst( 'M', n, d, e )
376 IF( orgnrm.EQ.zero )
377 $ RETURN
378 CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, ierr )
379 CALL slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, ierr )
380*
381 eps = slamch( 'Epsilon' )
382*
383 mlvl = int( log( real( n ) / real( smlsiz+1 ) ) / log( two ) ) + 1
384 smlszp = smlsiz + 1
385*
386 IF( icompq.EQ.1 ) THEN
387 iu = 1
388 ivt = 1 + smlsiz
389 difl = ivt + smlszp
390 difr = difl + mlvl
391 z = difr + mlvl*2
392 ic = z + mlvl
393 is = ic + 1
394 poles = is + 1
395 givnum = poles + 2*mlvl
396*
397 k = 1
398 givptr = 2
399 perm = 3
400 givcol = perm + mlvl
401 END IF
402*
403 DO 20 i = 1, n
404 IF( abs( d( i ) ).LT.eps ) THEN
405 d( i ) = sign( eps, d( i ) )
406 END IF
407 20 CONTINUE
408*
409 start = 1
410 sqre = 0
411*
412 DO 30 i = 1, nm1
413 IF( ( abs( e( i ) ).LT.eps ) .OR. ( i.EQ.nm1 ) ) THEN
414*
415* Subproblem found. First determine its size and then
416* apply divide and conquer on it.
417*
418 IF( i.LT.nm1 ) THEN
419*
420* A subproblem with E(I) small for I < NM1.
421*
422 nsize = i - start + 1
423 ELSE IF( abs( e( i ) ).GE.eps ) THEN
424*
425* A subproblem with E(NM1) not too small but I = NM1.
426*
427 nsize = n - start + 1
428 ELSE
429*
430* A subproblem with E(NM1) small. This implies an
431* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
432* first.
433*
434 nsize = i - start + 1
435 IF( icompq.EQ.2 ) THEN
436 u( n, n ) = sign( one, d( n ) )
437 vt( n, n ) = one
438 ELSE IF( icompq.EQ.1 ) THEN
439 q( n+( qstart-1 )*n ) = sign( one, d( n ) )
440 q( n+( smlsiz+qstart-1 )*n ) = one
441 END IF
442 d( n ) = abs( d( n ) )
443 END IF
444 IF( icompq.EQ.2 ) THEN
445 CALL slasd0( nsize, sqre, d( start ), e( start ),
446 $ u( start, start ), ldu, vt( start, start ),
447 $ ldvt, smlsiz, iwork, work( wstart ), info )
448 ELSE
449 CALL slasda( icompq, smlsiz, nsize, sqre, d( start ),
450 $ e( start ), q( start+( iu+qstart-2 )*n ), n,
451 $ q( start+( ivt+qstart-2 )*n ),
452 $ iq( start+k*n ), q( start+( difl+qstart-2 )*
453 $ n ), q( start+( difr+qstart-2 )*n ),
454 $ q( start+( z+qstart-2 )*n ),
455 $ q( start+( poles+qstart-2 )*n ),
456 $ iq( start+givptr*n ), iq( start+givcol*n ),
457 $ n, iq( start+perm*n ),
458 $ q( start+( givnum+qstart-2 )*n ),
459 $ q( start+( ic+qstart-2 )*n ),
460 $ q( start+( is+qstart-2 )*n ),
461 $ work( wstart ), iwork, info )
462 END IF
463 IF( info.NE.0 ) THEN
464 RETURN
465 END IF
466 start = i + 1
467 END IF
468 30 CONTINUE
469*
470* Unscale
471*
472 CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr )
473 40 CONTINUE
474*
475* Use Selection Sort to minimize swaps of singular vectors
476*
477 DO 60 ii = 2, n
478 i = ii - 1
479 kk = i
480 p = d( i )
481 DO 50 j = ii, n
482 IF( d( j ).GT.p ) THEN
483 kk = j
484 p = d( j )
485 END IF
486 50 CONTINUE
487 IF( kk.NE.i ) THEN
488 d( kk ) = d( i )
489 d( i ) = p
490 IF( icompq.EQ.1 ) THEN
491 iq( i ) = kk
492 ELSE IF( icompq.EQ.2 ) THEN
493 CALL sswap( n, u( 1, i ), 1, u( 1, kk ), 1 )
494 CALL sswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt )
495 END IF
496 ELSE IF( icompq.EQ.1 ) THEN
497 iq( i ) = i
498 END IF
499 60 CONTINUE
500*
501* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
502*
503 IF( icompq.EQ.1 ) THEN
504 IF( iuplo.EQ.1 ) THEN
505 iq( n ) = 1
506 ELSE
507 iq( n ) = 0
508 END IF
509 END IF
510*
511* If B is lower bidiagonal, update U by those Givens rotations
512* which rotated B to be upper bidiagonal
513*
514 IF( ( iuplo.EQ.2 ) .AND. ( icompq.EQ.2 ) )
515 $ CALL slasr( 'L', 'V', 'B', n, n, work( 1 ), work( n ), u, ldu )
516*
517 RETURN
518*
519* End of SBDSDC
520*
slasda
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 diagona...
Definition slasda.f:273
slasdq
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....
Definition slasdq.f:211
slaset
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.
Definition slaset.f:110
slasr
subroutine slasr(side, pivot, direct, m, n, c, s, a, lda)
SLASR applies a sequence of plane rotations to a general rectangular matrix.
Definition slasr.f:199
slartg
subroutine slartg(f, g, c, s, r)
SLARTG generates a plane rotation with real cosine and real sine.
Definition slartg.f90:113
slasd0
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 of...
Definition slasd0.f:150
slascl
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.
Definition slascl.f:143
slanst
real function slanst(norm, n, d, e)
SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slanst.f:100
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ sbdsqr()

subroutine sbdsqr ( character uplo,
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 )

SBDSQR

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

Purpose:
!>
!> SBDSQR computes the singular values and, optionally, the right and/or
!> left singular vectors from the singular value decomposition (SVD) of
!> a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
!> zero-shift QR algorithm.  The SVD of B has the form
!>
!>    B = Q * S * P**T
!>
!> where S is the diagonal matrix of singular values, Q is an orthogonal
!> matrix of left singular vectors, and P is an orthogonal matrix of
!> right singular vectors.  If left singular vectors are requested, this
!> subroutine actually returns U*Q instead of Q, and, if right singular
!> vectors are requested, this subroutine returns P**T*VT instead of
!> P**T, for given real input matrices U and VT.  When U and VT are the
!> orthogonal matrices that reduce a general matrix A to bidiagonal
!> form:  A = U*B*VT, as computed by SGEBRD, then
!>
!>    A = (U*Q) * S * (P**T*VT)
!>
!> is the SVD of A.  Optionally, the subroutine may also compute Q**T*C
!> for a given real input matrix C.
!>
!> See  by J. Demmel and W. Kahan,
!> LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
!> no. 5, pp. 873-912, Sept 1990) and
!>  by
!> B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
!> Department, University of California at Berkeley, July 1992
!> for a detailed description of the algorithm.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal;
!>          = 'L':  B is lower bidiagonal.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!>
[in]NCVT
!>          NCVT is INTEGER
!>          The number of columns of the matrix VT. NCVT >= 0.
!>
[in]NRU
!>          NRU is INTEGER
!>          The number of rows of the matrix U. NRU >= 0.
!>
[in]NCC
!>          NCC is INTEGER
!>          The number of columns of the matrix C. NCC >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B in decreasing
!>          order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the N-1 offdiagonal elements of the bidiagonal
!>          matrix B.
!>          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
!>          will contain the diagonal and superdiagonal elements of a
!>          bidiagonal matrix orthogonally equivalent to the one given
!>          as input.
!>
[in,out]VT
!>          VT is REAL array, dimension (LDVT, NCVT)
!>          On entry, an N-by-NCVT matrix VT.
!>          On exit, VT is overwritten by P**T * VT.
!>          Not referenced if NCVT = 0.
!>
[in]LDVT
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.
!>          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
!>
[in,out]U
!>          U is REAL array, dimension (LDU, N)
!>          On entry, an NRU-by-N matrix U.
!>          On exit, U is overwritten by U * Q.
!>          Not referenced if NRU = 0.
!>
[in]LDU
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= max(1,NRU).
!>
[in,out]C
!>          C is REAL array, dimension (LDC, NCC)
!>          On entry, an N-by-NCC matrix C.
!>          On exit, C is overwritten by Q**T * C.
!>          Not referenced if NCC = 0.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.
!>          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
!>
[out]WORK
!>          WORK is REAL array, dimension (4*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  If INFO = -i, the i-th argument had an illegal value
!>          > 0:
!>             if NCVT = NRU = NCC = 0,
!>                = 1, a split was marked by a positive value in E
!>                = 2, current block of Z not diagonalized after 30*N
!>                     iterations (in inner while loop)
!>                = 3, termination criterion of outer while loop not met
!>                     (program created more than N unreduced blocks)
!>             else NCVT = NRU = NCC = 0,
!>                   the algorithm did not converge; D and E contain the
!>                   elements of a bidiagonal matrix which is orthogonally
!>                   similar to the input matrix B;  if INFO = i, i
!>                   elements of E have not converged to zero.
!>
Internal Parameters:
!>  TOLMUL  REAL, default = max(10,min(100,EPS**(-1/8)))
!>          TOLMUL controls the convergence criterion of the QR loop.
!>          If it is positive, TOLMUL*EPS is the desired relative
!>             precision in the computed singular values.
!>          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
!>             desired absolute accuracy in the computed singular
!>             values (corresponds to relative accuracy
!>             abs(TOLMUL*EPS) in the largest singular value.
!>          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
!>             between 10 (for fast convergence) and .1/EPS
!>             (for there to be some accuracy in the results).
!>          Default is to lose at either one eighth or 2 of the
!>             available decimal digits in each computed singular value
!>             (whichever is smaller).
!>
!>  MAXITR  INTEGER, default = 6
!>          MAXITR controls the maximum number of passes of the
!>          algorithm through its inner loop. The algorithms stops
!>          (and so fails to converge) if the number of passes
!>          through the inner loop exceeds MAXITR*N**2.
!>
Note:
!>  Bug report from Cezary Dendek.
!>  On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is
!>  removed since it can overflow pretty easily (for N larger or equal
!>  than 18,919). We instead use MAXITDIVN = MAXITR*N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 238 of file sbdsqr.f.

240*
241* -- LAPACK computational routine --
242* -- LAPACK is a software package provided by Univ. of Tennessee, --
243* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
244*
245* .. Scalar Arguments ..
246 CHARACTER UPLO
247 INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
248* ..
249* .. Array Arguments ..
250 REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
251 $ VT( LDVT, * ), WORK( * )
252* ..
253*
254* =====================================================================
255*
256* .. Parameters ..
257 REAL ZERO
258 parameter( zero = 0.0e0 )
259 REAL ONE
260 parameter( one = 1.0e0 )
261 REAL NEGONE
262 parameter( negone = -1.0e0 )
263 REAL HNDRTH
264 parameter( hndrth = 0.01e0 )
265 REAL TEN
266 parameter( ten = 10.0e0 )
267 REAL HNDRD
268 parameter( hndrd = 100.0e0 )
269 REAL MEIGTH
270 parameter( meigth = -0.125e0 )
271 INTEGER MAXITR
272 parameter( maxitr = 6 )
273* ..
274* .. Local Scalars ..
275 LOGICAL LOWER, ROTATE
276 INTEGER I, IDIR, ISUB, ITER, ITERDIVN, J, LL, LLL, M,
277 $ MAXITDIVN, NM1, NM12, NM13, OLDLL, OLDM
278 REAL ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
279 $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
280 $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
281 $ SN, THRESH, TOL, TOLMUL, UNFL
282* ..
283* .. External Functions ..
284 LOGICAL LSAME
285 REAL SLAMCH
286 EXTERNAL lsame, slamch
287* ..
288* .. External Subroutines ..
289 EXTERNAL slartg, slas2, slasq1, slasr, slasv2, srot,
290 $ sscal, sswap, xerbla
291* ..
292* .. Intrinsic Functions ..
293 INTRINSIC abs, max, min, real, sign, sqrt
294* ..
295* .. Executable Statements ..
296*
297* Test the input parameters.
298*
299 info = 0
300 lower = lsame( uplo, 'L' )
301 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lower ) THEN
302 info = -1
303 ELSE IF( n.LT.0 ) THEN
304 info = -2
305 ELSE IF( ncvt.LT.0 ) THEN
306 info = -3
307 ELSE IF( nru.LT.0 ) THEN
308 info = -4
309 ELSE IF( ncc.LT.0 ) THEN
310 info = -5
311 ELSE IF( ( ncvt.EQ.0 .AND. ldvt.LT.1 ) .OR.
312 $ ( ncvt.GT.0 .AND. ldvt.LT.max( 1, n ) ) ) THEN
313 info = -9
314 ELSE IF( ldu.LT.max( 1, nru ) ) THEN
315 info = -11
316 ELSE IF( ( ncc.EQ.0 .AND. ldc.LT.1 ) .OR.
317 $ ( ncc.GT.0 .AND. ldc.LT.max( 1, n ) ) ) THEN
318 info = -13
319 END IF
320 IF( info.NE.0 ) THEN
321 CALL xerbla( 'SBDSQR', -info )
322 RETURN
323 END IF
324 IF( n.EQ.0 )
325 $ RETURN
326 IF( n.EQ.1 )
327 $ GO TO 160
328*
329* ROTATE is true if any singular vectors desired, false otherwise
330*
331 rotate = ( ncvt.GT.0 ) .OR. ( nru.GT.0 ) .OR. ( ncc.GT.0 )
332*
333* If no singular vectors desired, use qd algorithm
334*
335 IF( .NOT.rotate ) THEN
336 CALL slasq1( n, d, e, work, info )
337*
338* If INFO equals 2, dqds didn't finish, try to finish
339*
340 IF( info .NE. 2 ) RETURN
341 info = 0
342 END IF
343*
344 nm1 = n - 1
345 nm12 = nm1 + nm1
346 nm13 = nm12 + nm1
347 idir = 0
348*
349* Get machine constants
350*
351 eps = slamch( 'Epsilon' )
352 unfl = slamch( 'Safe minimum' )
353*
354* If matrix lower bidiagonal, rotate to be upper bidiagonal
355* by applying Givens rotations on the left
356*
357 IF( lower ) THEN
358 DO 10 i = 1, n - 1
359 CALL slartg( d( i ), e( i ), cs, sn, r )
360 d( i ) = r
361 e( i ) = sn*d( i+1 )
362 d( i+1 ) = cs*d( i+1 )
363 work( i ) = cs
364 work( nm1+i ) = sn
365 10 CONTINUE
366*
367* Update singular vectors if desired
368*
369 IF( nru.GT.0 )
370 $ CALL slasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,
371 $ ldu )
372 IF( ncc.GT.0 )
373 $ CALL slasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,
374 $ ldc )
375 END IF
376*
377* Compute singular values to relative accuracy TOL
378* (By setting TOL to be negative, algorithm will compute
379* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
380*
381 tolmul = max( ten, min( hndrd, eps**meigth ) )
382 tol = tolmul*eps
383*
384* Compute approximate maximum, minimum singular values
385*
386 smax = zero
387 DO 20 i = 1, n
388 smax = max( smax, abs( d( i ) ) )
389 20 CONTINUE
390 DO 30 i = 1, n - 1
391 smax = max( smax, abs( e( i ) ) )
392 30 CONTINUE
393 sminl = zero
394 IF( tol.GE.zero ) THEN
395*
396* Relative accuracy desired
397*
398 sminoa = abs( d( 1 ) )
399 IF( sminoa.EQ.zero )
400 $ GO TO 50
401 mu = sminoa
402 DO 40 i = 2, n
403 mu = abs( d( i ) )*( mu / ( mu+abs( e( i-1 ) ) ) )
404 sminoa = min( sminoa, mu )
405 IF( sminoa.EQ.zero )
406 $ GO TO 50
407 40 CONTINUE
408 50 CONTINUE
409 sminoa = sminoa / sqrt( real( n ) )
410 thresh = max( tol*sminoa, maxitr*(n*(n*unfl)) )
411 ELSE
412*
413* Absolute accuracy desired
414*
415 thresh = max( abs( tol )*smax, maxitr*(n*(n*unfl)) )
416 END IF
417*
418* Prepare for main iteration loop for the singular values
419* (MAXIT is the maximum number of passes through the inner
420* loop permitted before nonconvergence signalled.)
421*
422 maxitdivn = maxitr*n
423 iterdivn = 0
424 iter = -1
425 oldll = -1
426 oldm = -1
427*
428* M points to last element of unconverged part of matrix
429*
430 m = n
431*
432* Begin main iteration loop
433*
434 60 CONTINUE
435*
436* Check for convergence or exceeding iteration count
437*
438 IF( m.LE.1 )
439 $ GO TO 160
440*
441 IF( iter.GE.n ) THEN
442 iter = iter - n
443 iterdivn = iterdivn + 1
444 IF( iterdivn.GE.maxitdivn )
445 $ GO TO 200
446 END IF
447*
448* Find diagonal block of matrix to work on
449*
450 IF( tol.LT.zero .AND. abs( d( m ) ).LE.thresh )
451 $ d( m ) = zero
452 smax = abs( d( m ) )
453 smin = smax
454 DO 70 lll = 1, m - 1
455 ll = m - lll
456 abss = abs( d( ll ) )
457 abse = abs( e( ll ) )
458 IF( tol.LT.zero .AND. abss.LE.thresh )
459 $ d( ll ) = zero
460 IF( abse.LE.thresh )
461 $ GO TO 80
462 smin = min( smin, abss )
463 smax = max( smax, abss, abse )
464 70 CONTINUE
465 ll = 0
466 GO TO 90
467 80 CONTINUE
468 e( ll ) = zero
469*
470* Matrix splits since E(LL) = 0
471*
472 IF( ll.EQ.m-1 ) THEN
473*
474* Convergence of bottom singular value, return to top of loop
475*
476 m = m - 1
477 GO TO 60
478 END IF
479 90 CONTINUE
480 ll = ll + 1
481*
482* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
483*
484 IF( ll.EQ.m-1 ) THEN
485*
486* 2 by 2 block, handle separately
487*
488 CALL slasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,
489 $ cosr, sinl, cosl )
490 d( m-1 ) = sigmx
491 e( m-1 ) = zero
492 d( m ) = sigmn
493*
494* Compute singular vectors, if desired
495*
496 IF( ncvt.GT.0 )
497 $ CALL srot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,
498 $ sinr )
499 IF( nru.GT.0 )
500 $ CALL srot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl )
501 IF( ncc.GT.0 )
502 $ CALL srot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,
503 $ sinl )
504 m = m - 2
505 GO TO 60
506 END IF
507*
508* If working on new submatrix, choose shift direction
509* (from larger end diagonal element towards smaller)
510*
511 IF( ll.GT.oldm .OR. m.LT.oldll ) THEN
512 IF( abs( d( ll ) ).GE.abs( d( m ) ) ) THEN
513*
514* Chase bulge from top (big end) to bottom (small end)
515*
516 idir = 1
517 ELSE
518*
519* Chase bulge from bottom (big end) to top (small end)
520*
521 idir = 2
522 END IF
523 END IF
524*
525* Apply convergence tests
526*
527 IF( idir.EQ.1 ) THEN
528*
529* Run convergence test in forward direction
530* First apply standard test to bottom of matrix
531*
532 IF( abs( e( m-1 ) ).LE.abs( tol )*abs( d( m ) ) .OR.
533 $ ( tol.LT.zero .AND. abs( e( m-1 ) ).LE.thresh ) ) THEN
534 e( m-1 ) = zero
535 GO TO 60
536 END IF
537*
538 IF( tol.GE.zero ) THEN
539*
540* If relative accuracy desired,
541* apply convergence criterion forward
542*
543 mu = abs( d( ll ) )
544 sminl = mu
545 DO 100 lll = ll, m - 1
546 IF( abs( e( lll ) ).LE.tol*mu ) THEN
547 e( lll ) = zero
548 GO TO 60
549 END IF
550 mu = abs( d( lll+1 ) )*( mu / ( mu+abs( e( lll ) ) ) )
551 sminl = min( sminl, mu )
552 100 CONTINUE
553 END IF
554*
555 ELSE
556*
557* Run convergence test in backward direction
558* First apply standard test to top of matrix
559*
560 IF( abs( e( ll ) ).LE.abs( tol )*abs( d( ll ) ) .OR.
561 $ ( tol.LT.zero .AND. abs( e( ll ) ).LE.thresh ) ) THEN
562 e( ll ) = zero
563 GO TO 60
564 END IF
565*
566 IF( tol.GE.zero ) THEN
567*
568* If relative accuracy desired,
569* apply convergence criterion backward
570*
571 mu = abs( d( m ) )
572 sminl = mu
573 DO 110 lll = m - 1, ll, -1
574 IF( abs( e( lll ) ).LE.tol*mu ) THEN
575 e( lll ) = zero
576 GO TO 60
577 END IF
578 mu = abs( d( lll ) )*( mu / ( mu+abs( e( lll ) ) ) )
579 sminl = min( sminl, mu )
580 110 CONTINUE
581 END IF
582 END IF
583 oldll = ll
584 oldm = m
585*
586* Compute shift. First, test if shifting would ruin relative
587* accuracy, and if so set the shift to zero.
588*
589 IF( tol.GE.zero .AND. n*tol*( sminl / smax ).LE.
590 $ max( eps, hndrth*tol ) ) THEN
591*
592* Use a zero shift to avoid loss of relative accuracy
593*
594 shift = zero
595 ELSE
596*
597* Compute the shift from 2-by-2 block at end of matrix
598*
599 IF( idir.EQ.1 ) THEN
600 sll = abs( d( ll ) )
601 CALL slas2( d( m-1 ), e( m-1 ), d( m ), shift, r )
602 ELSE
603 sll = abs( d( m ) )
604 CALL slas2( d( ll ), e( ll ), d( ll+1 ), shift, r )
605 END IF
606*
607* Test if shift negligible, and if so set to zero
608*
609 IF( sll.GT.zero ) THEN
610 IF( ( shift / sll )**2.LT.eps )
611 $ shift = zero
612 END IF
613 END IF
614*
615* Increment iteration count
616*
617 iter = iter + m - ll
618*
619* If SHIFT = 0, do simplified QR iteration
620*
621 IF( shift.EQ.zero ) THEN
622 IF( idir.EQ.1 ) THEN
623*
624* Chase bulge from top to bottom
625* Save cosines and sines for later singular vector updates
626*
627 cs = one
628 oldcs = one
629 DO 120 i = ll, m - 1
630 CALL slartg( d( i )*cs, e( i ), cs, sn, r )
631 IF( i.GT.ll )
632 $ e( i-1 ) = oldsn*r
633 CALL slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) )
634 work( i-ll+1 ) = cs
635 work( i-ll+1+nm1 ) = sn
636 work( i-ll+1+nm12 ) = oldcs
637 work( i-ll+1+nm13 ) = oldsn
638 120 CONTINUE
639 h = d( m )*cs
640 d( m ) = h*oldcs
641 e( m-1 ) = h*oldsn
642*
643* Update singular vectors
644*
645 IF( ncvt.GT.0 )
646 $ CALL slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),
647 $ work( n ), vt( ll, 1 ), ldvt )
648 IF( nru.GT.0 )
649 $ CALL slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),
650 $ work( nm13+1 ), u( 1, ll ), ldu )
651 IF( ncc.GT.0 )
652 $ CALL slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),
653 $ work( nm13+1 ), c( ll, 1 ), ldc )
654*
655* Test convergence
656*
657 IF( abs( e( m-1 ) ).LE.thresh )
658 $ e( m-1 ) = zero
659*
660 ELSE
661*
662* Chase bulge from bottom to top
663* Save cosines and sines for later singular vector updates
664*
665 cs = one
666 oldcs = one
667 DO 130 i = m, ll + 1, -1
668 CALL slartg( d( i )*cs, e( i-1 ), cs, sn, r )
669 IF( i.LT.m )
670 $ e( i ) = oldsn*r
671 CALL slartg( oldcs*r, d( i-1 )*sn, oldcs, oldsn, d( i ) )
672 work( i-ll ) = cs
673 work( i-ll+nm1 ) = -sn
674 work( i-ll+nm12 ) = oldcs
675 work( i-ll+nm13 ) = -oldsn
676 130 CONTINUE
677 h = d( ll )*cs
678 d( ll ) = h*oldcs
679 e( ll ) = h*oldsn
680*
681* Update singular vectors
682*
683 IF( ncvt.GT.0 )
684 $ CALL slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),
685 $ work( nm13+1 ), vt( ll, 1 ), ldvt )
686 IF( nru.GT.0 )
687 $ CALL slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),
688 $ work( n ), u( 1, ll ), ldu )
689 IF( ncc.GT.0 )
690 $ CALL slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),
691 $ work( n ), c( ll, 1 ), ldc )
692*
693* Test convergence
694*
695 IF( abs( e( ll ) ).LE.thresh )
696 $ e( ll ) = zero
697 END IF
698 ELSE
699*
700* Use nonzero shift
701*
702 IF( idir.EQ.1 ) THEN
703*
704* Chase bulge from top to bottom
705* Save cosines and sines for later singular vector updates
706*
707 f = ( abs( d( ll ) )-shift )*
708 $ ( sign( one, d( ll ) )+shift / d( ll ) )
709 g = e( ll )
710 DO 140 i = ll, m - 1
711 CALL slartg( f, g, cosr, sinr, r )
712 IF( i.GT.ll )
713 $ e( i-1 ) = r
714 f = cosr*d( i ) + sinr*e( i )
715 e( i ) = cosr*e( i ) - sinr*d( i )
716 g = sinr*d( i+1 )
717 d( i+1 ) = cosr*d( i+1 )
718 CALL slartg( f, g, cosl, sinl, r )
719 d( i ) = r
720 f = cosl*e( i ) + sinl*d( i+1 )
721 d( i+1 ) = cosl*d( i+1 ) - sinl*e( i )
722 IF( i.LT.m-1 ) THEN
723 g = sinl*e( i+1 )
724 e( i+1 ) = cosl*e( i+1 )
725 END IF
726 work( i-ll+1 ) = cosr
727 work( i-ll+1+nm1 ) = sinr
728 work( i-ll+1+nm12 ) = cosl
729 work( i-ll+1+nm13 ) = sinl
730 140 CONTINUE
731 e( m-1 ) = f
732*
733* Update singular vectors
734*
735 IF( ncvt.GT.0 )
736 $ CALL slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),
737 $ work( n ), vt( ll, 1 ), ldvt )
738 IF( nru.GT.0 )
739 $ CALL slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),
740 $ work( nm13+1 ), u( 1, ll ), ldu )
741 IF( ncc.GT.0 )
742 $ CALL slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),
743 $ work( nm13+1 ), c( ll, 1 ), ldc )
744*
745* Test convergence
746*
747 IF( abs( e( m-1 ) ).LE.thresh )
748 $ e( m-1 ) = zero
749*
750 ELSE
751*
752* Chase bulge from bottom to top
753* Save cosines and sines for later singular vector updates
754*
755 f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /
756 $ d( m ) )
757 g = e( m-1 )
758 DO 150 i = m, ll + 1, -1
759 CALL slartg( f, g, cosr, sinr, r )
760 IF( i.LT.m )
761 $ e( i ) = r
762 f = cosr*d( i ) + sinr*e( i-1 )
763 e( i-1 ) = cosr*e( i-1 ) - sinr*d( i )
764 g = sinr*d( i-1 )
765 d( i-1 ) = cosr*d( i-1 )
766 CALL slartg( f, g, cosl, sinl, r )
767 d( i ) = r
768 f = cosl*e( i-1 ) + sinl*d( i-1 )
769 d( i-1 ) = cosl*d( i-1 ) - sinl*e( i-1 )
770 IF( i.GT.ll+1 ) THEN
771 g = sinl*e( i-2 )
772 e( i-2 ) = cosl*e( i-2 )
773 END IF
774 work( i-ll ) = cosr
775 work( i-ll+nm1 ) = -sinr
776 work( i-ll+nm12 ) = cosl
777 work( i-ll+nm13 ) = -sinl
778 150 CONTINUE
779 e( ll ) = f
780*
781* Test convergence
782*
783 IF( abs( e( ll ) ).LE.thresh )
784 $ e( ll ) = zero
785*
786* Update singular vectors if desired
787*
788 IF( ncvt.GT.0 )
789 $ CALL slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),
790 $ work( nm13+1 ), vt( ll, 1 ), ldvt )
791 IF( nru.GT.0 )
792 $ CALL slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),
793 $ work( n ), u( 1, ll ), ldu )
794 IF( ncc.GT.0 )
795 $ CALL slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),
796 $ work( n ), c( ll, 1 ), ldc )
797 END IF
798 END IF
799*
800* QR iteration finished, go back and check convergence
801*
802 GO TO 60
803*
804* All singular values converged, so make them positive
805*
806 160 CONTINUE
807 DO 170 i = 1, n
808 IF( d( i ).LT.zero ) THEN
809 d( i ) = -d( i )
810*
811* Change sign of singular vectors, if desired
812*
813 IF( ncvt.GT.0 )
814 $ CALL sscal( ncvt, negone, vt( i, 1 ), ldvt )
815 END IF
816 170 CONTINUE
817*
818* Sort the singular values into decreasing order (insertion sort on
819* singular values, but only one transposition per singular vector)
820*
821 DO 190 i = 1, n - 1
822*
823* Scan for smallest D(I)
824*
825 isub = 1
826 smin = d( 1 )
827 DO 180 j = 2, n + 1 - i
828 IF( d( j ).LE.smin ) THEN
829 isub = j
830 smin = d( j )
831 END IF
832 180 CONTINUE
833 IF( isub.NE.n+1-i ) THEN
834*
835* Swap singular values and vectors
836*
837 d( isub ) = d( n+1-i )
838 d( n+1-i ) = smin
839 IF( ncvt.GT.0 )
840 $ CALL sswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),
841 $ ldvt )
842 IF( nru.GT.0 )
843 $ CALL sswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 )
844 IF( ncc.GT.0 )
845 $ CALL sswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc )
846 END IF
847 190 CONTINUE
848 GO TO 220
849*
850* Maximum number of iterations exceeded, failure to converge
851*
852 200 CONTINUE
853 info = 0
854 DO 210 i = 1, n - 1
855 IF( e( i ).NE.zero )
856 $ info = info + 1
857 210 CONTINUE
858 220 CONTINUE
859 RETURN
860*
861* End of SBDSQR
862*
slasv2
subroutine slasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition slasv2.f:138
slas2
subroutine slas2(f, g, h, ssmin, ssmax)
SLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition slas2.f:107
slasq1
subroutine slasq1(n, d, e, work, info)
SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.
Definition slasq1.f:108
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92

◆ sdisna()

subroutine sdisna ( character job,
integer m,
integer n,
real, dimension( * ) d,
real, dimension( * ) sep,
integer info )

SDISNA

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

Purpose:
!>
!> SDISNA computes the reciprocal condition numbers for the eigenvectors
!> of a real symmetric or complex Hermitian matrix or for the left or
!> right singular vectors of a general m-by-n matrix. The reciprocal
!> condition number is the 'gap' between the corresponding eigenvalue or
!> singular value and the nearest other one.
!>
!> The bound on the error, measured by angle in radians, in the I-th
!> computed vector is given by
!>
!>        SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
!>
!> where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed
!> to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
!> the error bound.
!>
!> SDISNA may also be used to compute error bounds for eigenvectors of
!> the generalized symmetric definite eigenproblem.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER*1
!>          Specifies for which problem the reciprocal condition numbers
!>          should be computed:
!>          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;
!>          = 'L':  the left singular vectors of a general matrix;
!>          = 'R':  the right singular vectors of a general matrix.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          If JOB = 'L' or 'R', the number of columns of the matrix,
!>          in which case N >= 0. Ignored if JOB = 'E'.
!>
[in]D
!>          D is REAL array, dimension (M) if JOB = 'E'
!>                              dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The eigenvalues (if JOB = 'E') or singular values (if JOB =
!>          'L' or 'R') of the matrix, in either increasing or decreasing
!>          order. If singular values, they must be non-negative.
!>
[out]SEP
!>          SEP is REAL array, dimension (M) if JOB = 'E'
!>                               dimension (min(M,N)) if JOB = 'L' or 'R'
!>          The reciprocal condition numbers of the vectors.
!>
[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 116 of file sdisna.f.

117*
118* -- LAPACK computational routine --
119* -- LAPACK is a software package provided by Univ. of Tennessee, --
120* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
121*
122* .. Scalar Arguments ..
123 CHARACTER JOB
124 INTEGER INFO, M, N
125* ..
126* .. Array Arguments ..
127 REAL D( * ), SEP( * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 REAL ZERO
134 parameter( zero = 0.0e+0 )
135* ..
136* .. Local Scalars ..
137 LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
138 INTEGER I, K
139 REAL ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 REAL SLAMCH
144 EXTERNAL lsame, slamch
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, max, min
148* ..
149* .. External Subroutines ..
150 EXTERNAL xerbla
151* ..
152* .. Executable Statements ..
153*
154* Test the input arguments
155*
156 info = 0
157 eigen = lsame( job, 'E' )
158 left = lsame( job, 'L' )
159 right = lsame( job, 'R' )
160 sing = left .OR. right
161 IF( eigen ) THEN
162 k = m
163 ELSE IF( sing ) THEN
164 k = min( m, n )
165 END IF
166 IF( .NOT.eigen .AND. .NOT.sing ) THEN
167 info = -1
168 ELSE IF( m.LT.0 ) THEN
169 info = -2
170 ELSE IF( k.LT.0 ) THEN
171 info = -3
172 ELSE
173 incr = .true.
174 decr = .true.
175 DO 10 i = 1, k - 1
176 IF( incr )
177 $ incr = incr .AND. d( i ).LE.d( i+1 )
178 IF( decr )
179 $ decr = decr .AND. d( i ).GE.d( i+1 )
180 10 CONTINUE
181 IF( sing .AND. k.GT.0 ) THEN
182 IF( incr )
183 $ incr = incr .AND. zero.LE.d( 1 )
184 IF( decr )
185 $ decr = decr .AND. d( k ).GE.zero
186 END IF
187 IF( .NOT.( incr .OR. decr ) )
188 $ info = -4
189 END IF
190 IF( info.NE.0 ) THEN
191 CALL xerbla( 'SDISNA', -info )
192 RETURN
193 END IF
194*
195* Quick return if possible
196*
197 IF( k.EQ.0 )
198 $ RETURN
199*
200* Compute reciprocal condition numbers
201*
202 IF( k.EQ.1 ) THEN
203 sep( 1 ) = slamch( 'O' )
204 ELSE
205 oldgap = abs( d( 2 )-d( 1 ) )
206 sep( 1 ) = oldgap
207 DO 20 i = 2, k - 1
208 newgap = abs( d( i+1 )-d( i ) )
209 sep( i ) = min( oldgap, newgap )
210 oldgap = newgap
211 20 CONTINUE
212 sep( k ) = oldgap
213 END IF
214 IF( sing ) THEN
215 IF( ( left .AND. m.GT.n ) .OR. ( right .AND. m.LT.n ) ) THEN
216 IF( incr )
217 $ sep( 1 ) = min( sep( 1 ), d( 1 ) )
218 IF( decr )
219 $ sep( k ) = min( sep( k ), d( k ) )
220 END IF
221 END IF
222*
223* Ensure that reciprocal condition numbers are not less than
224* threshold, in order to limit the size of the error bound
225*
226 eps = slamch( 'E' )
227 safmin = slamch( 'S' )
228 anorm = max( abs( d( 1 ) ), abs( d( k ) ) )
229 IF( anorm.EQ.zero ) THEN
230 thresh = eps
231 ELSE
232 thresh = max( eps*anorm, safmin )
233 END IF
234 DO 30 i = 1, k
235 sep( i ) = max( sep( i ), thresh )
236 30 CONTINUE
237*
238 RETURN
239*
240* End of SDISNA
241*

◆ slaed0()

subroutine slaed0 ( integer icompq,
integer qsiz,
integer n,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldq, * ) q,
integer ldq,
real, dimension( ldqs, * ) qstore,
integer ldqs,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SLAED0 used by SSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmetric tridiagonal matrix using the divide and conquer method.

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

Purpose:
!>
!> SLAED0 computes all eigenvalues and corresponding eigenvectors of a
!> symmetric tridiagonal matrix using the divide and conquer method.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>          = 2:  Compute eigenvalues and eigenvectors of tridiagonal
!>                matrix.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>         On entry, the main diagonal of the tridiagonal matrix.
!>         On exit, its eigenvalues.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>         The off-diagonal elements of the tridiagonal matrix.
!>         On exit, E has been destroyed.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>         On entry, Q must contain an N-by-N orthogonal matrix.
!>         If ICOMPQ = 0    Q is not referenced.
!>         If ICOMPQ = 1    On entry, Q is a subset of the columns of the
!>                          orthogonal matrix used to reduce the full
!>                          matrix to tridiagonal form corresponding to
!>                          the subset of the full matrix which is being
!>                          decomposed at this time.
!>         If ICOMPQ = 2    On entry, Q will be the identity matrix.
!>                          On exit, Q contains the eigenvectors of the
!>                          tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  If eigenvectors are
!>         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.
!>
[out]QSTORE
!>          QSTORE is REAL array, dimension (LDQS, N)
!>         Referenced only when ICOMPQ = 1.  Used to store parts of
!>         the eigenvector matrix when the updating matrix multiplies
!>         take place.
!>
[in]LDQS
!>          LDQS is INTEGER
!>         The leading dimension of the array QSTORE.  If ICOMPQ = 1,
!>         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.
!>
[out]WORK
!>          WORK is REAL array,
!>         If ICOMPQ = 0 or 1, the dimension of WORK must be at least
!>                     1 + 3*N + 2*N*lg N + 3*N**2
!>                     ( lg( N ) = smallest integer k
!>                                 such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of WORK must be at least
!>                     4*N + N**2.
!>
[out]IWORK
!>          IWORK is INTEGER array,
!>         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
!>                        6 + 6*N + 5*N*lg N.
!>                        ( lg( N ) = smallest integer k
!>                                    such that 2^k >= N )
!>         If ICOMPQ = 2, the dimension of IWORK must be at least
!>                        3 + 5*N.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 170 of file slaed0.f.

172*
173* -- LAPACK computational routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
179* ..
180* .. Array Arguments ..
181 INTEGER IWORK( * )
182 REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
183 $ WORK( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ZERO, ONE, TWO
190 parameter( zero = 0.e0, one = 1.e0, two = 2.e0 )
191* ..
192* .. Local Scalars ..
193 INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
194 $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
195 $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
196 $ SPM2, SUBMAT, SUBPBS, TLVLS
197 REAL TEMP
198* ..
199* .. External Subroutines ..
200 EXTERNAL scopy, sgemm, slacpy, slaed1, slaed7, ssteqr,
201 $ xerbla
202* ..
203* .. External Functions ..
204 INTEGER ILAENV
205 EXTERNAL ilaenv
206* ..
207* .. Intrinsic Functions ..
208 INTRINSIC abs, int, log, max, real
209* ..
210* .. Executable Statements ..
211*
212* Test the input parameters.
213*
214 info = 0
215*
216 IF( icompq.LT.0 .OR. icompq.GT.2 ) THEN
217 info = -1
218 ELSE IF( ( icompq.EQ.1 ) .AND. ( qsiz.LT.max( 0, n ) ) ) THEN
219 info = -2
220 ELSE IF( n.LT.0 ) THEN
221 info = -3
222 ELSE IF( ldq.LT.max( 1, n ) ) THEN
223 info = -7
224 ELSE IF( ldqs.LT.max( 1, n ) ) THEN
225 info = -9
226 END IF
227 IF( info.NE.0 ) THEN
228 CALL xerbla( 'SLAED0', -info )
229 RETURN
230 END IF
231*
232* Quick return if possible
233*
234 IF( n.EQ.0 )
235 $ RETURN
236*
237 smlsiz = ilaenv( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
238*
239* Determine the size and placement of the submatrices, and save in
240* the leading elements of IWORK.
241*
242 iwork( 1 ) = n
243 subpbs = 1
244 tlvls = 0
245 10 CONTINUE
246 IF( iwork( subpbs ).GT.smlsiz ) THEN
247 DO 20 j = subpbs, 1, -1
248 iwork( 2*j ) = ( iwork( j )+1 ) / 2
249 iwork( 2*j-1 ) = iwork( j ) / 2
250 20 CONTINUE
251 tlvls = tlvls + 1
252 subpbs = 2*subpbs
253 GO TO 10
254 END IF
255 DO 30 j = 2, subpbs
256 iwork( j ) = iwork( j ) + iwork( j-1 )
257 30 CONTINUE
258*
259* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
260* using rank-1 modifications (cuts).
261*
262 spm1 = subpbs - 1
263 DO 40 i = 1, spm1
264 submat = iwork( i ) + 1
265 smm1 = submat - 1
266 d( smm1 ) = d( smm1 ) - abs( e( smm1 ) )
267 d( submat ) = d( submat ) - abs( e( smm1 ) )
268 40 CONTINUE
269*
270 indxq = 4*n + 3
271 IF( icompq.NE.2 ) THEN
272*
273* Set up workspaces for eigenvalues only/accumulate new vectors
274* routine
275*
276 temp = log( real( n ) ) / log( two )
277 lgn = int( temp )
278 IF( 2**lgn.LT.n )
279 $ lgn = lgn + 1
280 IF( 2**lgn.LT.n )
281 $ lgn = lgn + 1
282 iprmpt = indxq + n + 1
283 iperm = iprmpt + n*lgn
284 iqptr = iperm + n*lgn
285 igivpt = iqptr + n + 2
286 igivcl = igivpt + n*lgn
287*
288 igivnm = 1
289 iq = igivnm + 2*n*lgn
290 iwrem = iq + n**2 + 1
291*
292* Initialize pointers
293*
294 DO 50 i = 0, subpbs
295 iwork( iprmpt+i ) = 1
296 iwork( igivpt+i ) = 1
297 50 CONTINUE
298 iwork( iqptr ) = 1
299 END IF
300*
301* Solve each submatrix eigenproblem at the bottom of the divide and
302* conquer tree.
303*
304 curr = 0
305 DO 70 i = 0, spm1
306 IF( i.EQ.0 ) THEN
307 submat = 1
308 matsiz = iwork( 1 )
309 ELSE
310 submat = iwork( i ) + 1
311 matsiz = iwork( i+1 ) - iwork( i )
312 END IF
313 IF( icompq.EQ.2 ) THEN
314 CALL ssteqr( 'I', matsiz, d( submat ), e( submat ),
315 $ q( submat, submat ), ldq, work, info )
316 IF( info.NE.0 )
317 $ GO TO 130
318 ELSE
319 CALL ssteqr( 'I', matsiz, d( submat ), e( submat ),
320 $ work( iq-1+iwork( iqptr+curr ) ), matsiz, work,
321 $ info )
322 IF( info.NE.0 )
323 $ GO TO 130
324 IF( icompq.EQ.1 ) THEN
325 CALL sgemm( 'N', 'N', qsiz, matsiz, matsiz, one,
326 $ q( 1, submat ), ldq, work( iq-1+iwork( iqptr+
327 $ curr ) ), matsiz, zero, qstore( 1, submat ),
328 $ ldqs )
329 END IF
330 iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2
331 curr = curr + 1
332 END IF
333 k = 1
334 DO 60 j = submat, iwork( i+1 )
335 iwork( indxq+j ) = k
336 k = k + 1
337 60 CONTINUE
338 70 CONTINUE
339*
340* Successively merge eigensystems of adjacent submatrices
341* into eigensystem for the corresponding larger matrix.
342*
343* while ( SUBPBS > 1 )
344*
345 curlvl = 1
346 80 CONTINUE
347 IF( subpbs.GT.1 ) THEN
348 spm2 = subpbs - 2
349 DO 90 i = 0, spm2, 2
350 IF( i.EQ.0 ) THEN
351 submat = 1
352 matsiz = iwork( 2 )
353 msd2 = iwork( 1 )
354 curprb = 0
355 ELSE
356 submat = iwork( i ) + 1
357 matsiz = iwork( i+2 ) - iwork( i )
358 msd2 = matsiz / 2
359 curprb = curprb + 1
360 END IF
361*
362* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
363* into an eigensystem of size MATSIZ.
364* SLAED1 is used only for the full eigensystem of a tridiagonal
365* matrix.
366* SLAED7 handles the cases in which eigenvalues only or eigenvalues
367* and eigenvectors of a full symmetric matrix (which was reduced to
368* tridiagonal form) are desired.
369*
370 IF( icompq.EQ.2 ) THEN
371 CALL slaed1( matsiz, d( submat ), q( submat, submat ),
372 $ ldq, iwork( indxq+submat ),
373 $ e( submat+msd2-1 ), msd2, work,
374 $ iwork( subpbs+1 ), info )
375 ELSE
376 CALL slaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,
377 $ d( submat ), qstore( 1, submat ), ldqs,
378 $ iwork( indxq+submat ), e( submat+msd2-1 ),
379 $ msd2, work( iq ), iwork( iqptr ),
380 $ iwork( iprmpt ), iwork( iperm ),
381 $ iwork( igivpt ), iwork( igivcl ),
382 $ work( igivnm ), work( iwrem ),
383 $ iwork( subpbs+1 ), info )
384 END IF
385 IF( info.NE.0 )
386 $ GO TO 130
387 iwork( i / 2+1 ) = iwork( i+2 )
388 90 CONTINUE
389 subpbs = subpbs / 2
390 curlvl = curlvl + 1
391 GO TO 80
392 END IF
393*
394* end while
395*
396* Re-merge the eigenvalues/vectors which were deflated at the final
397* merge step.
398*
399 IF( icompq.EQ.1 ) THEN
400 DO 100 i = 1, n
401 j = iwork( indxq+i )
402 work( i ) = d( j )
403 CALL scopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 )
404 100 CONTINUE
405 CALL scopy( n, work, 1, d, 1 )
406 ELSE IF( icompq.EQ.2 ) THEN
407 DO 110 i = 1, n
408 j = iwork( indxq+i )
409 work( i ) = d( j )
410 CALL scopy( n, q( 1, j ), 1, work( n*i+1 ), 1 )
411 110 CONTINUE
412 CALL scopy( n, work, 1, d, 1 )
413 CALL slacpy( 'A', n, n, work( n+1 ), n, q, ldq )
414 ELSE
415 DO 120 i = 1, n
416 j = iwork( indxq+i )
417 work( i ) = d( j )
418 120 CONTINUE
419 CALL scopy( n, work, 1, d, 1 )
420 END IF
421 GO TO 140
422*
423 130 CONTINUE
424 info = submat*( n+1 ) + submat + matsiz - 1
425*
426 140 CONTINUE
427 RETURN
428*
429* End of SLAED0
430*
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
slaed7
subroutine slaed7(icompq, n, qsiz, tlvls, curlvl, curpbm, d, q, ldq, indxq, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, info)
SLAED7 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition slaed7.f:260
ssteqr
subroutine ssteqr(compz, n, d, e, z, ldz, work, info)
SSTEQR
Definition ssteqr.f:131
slaed1
subroutine slaed1(n, d, q, ldq, indxq, rho, cutpnt, work, iwork, info)
SLAED1 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a ...
Definition slaed1.f:163
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ slaed1()

subroutine slaed1 ( integer n,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
real rho,
integer cutpnt,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SLAED1 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> SLAED1 computes the updated eigensystem of a diagonal
!> matrix after modification by a rank-one symmetric matrix.  This
!> routine is used only for the eigenproblem which requires all
!> eigenvalues and eigenvectors of a tridiagonal matrix.  SLAED7 handles
!> the case in which eigenvalues only or eigenvalues and eigenvectors
!> of a full symmetric matrix (which was reduced to tridiagonal form)
!> are desired.
!>
!>   T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!>
!>    where Z = Q**T*u, u is a vector of length N with ones in the
!>    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!>
!>    The eigenvectors of the original matrix are stored in Q, and the
!>    eigenvalues are in D.  The algorithm consists of three stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple eigenvalues or if there is a zero in
!>       the Z vector.  For each such occurrence the dimension of the
!>       secular equation problem is reduced by one.  This stage is
!>       performed by the routine SLAED2.
!>
!>       The second stage consists of calculating the updated
!>       eigenvalues. This is done by finding the roots of the secular
!>       equation via the routine SLAED4 (as called by SLAED3).
!>       This routine also calculates the eigenvectors of the current
!>       problem.
!>
!>       The final stage consists of computing the updated eigenvectors
!>       directly using the updated eigenvalues.  The eigenvectors for
!>       the current problem are multiplied with the eigenvectors from
!>       the overall problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>         On entry, the eigenvalues of the rank-1-perturbed matrix.
!>         On exit, the eigenvalues of the repaired matrix.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>         On entry, the eigenvectors of the rank-1-perturbed matrix.
!>         On exit, the eigenvectors of the repaired tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in,out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         On entry, the permutation which separately sorts the two
!>         subproblems in D into ascending order.
!>         On exit, the permutation which will reintegrate the
!>         subproblems back into sorted order,
!>         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
!>
[in]RHO
!>          RHO is REAL
!>         The subdiagonal entry used to create the rank-1 modification.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         The location of the last eigenvalue in the leading sub-matrix.
!>         min(1,N) <= CUTPNT <= N/2.
!>
[out]WORK
!>          WORK is REAL array, dimension (4*N + N**2)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 161 of file slaed1.f.

163*
164* -- LAPACK computational routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 INTEGER CUTPNT, INFO, LDQ, N
170 REAL RHO
171* ..
172* .. Array Arguments ..
173 INTEGER INDXQ( * ), IWORK( * )
174 REAL D( * ), Q( LDQ, * ), WORK( * )
175* ..
176*
177* =====================================================================
178*
179* .. Local Scalars ..
180 INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
181 $ IQ2, IS, IW, IZ, K, N1, N2
182* ..
183* .. External Subroutines ..
184 EXTERNAL scopy, slaed2, slaed3, slamrg, xerbla
185* ..
186* .. Intrinsic Functions ..
187 INTRINSIC max, min
188* ..
189* .. Executable Statements ..
190*
191* Test the input parameters.
192*
193 info = 0
194*
195 IF( n.LT.0 ) THEN
196 info = -1
197 ELSE IF( ldq.LT.max( 1, n ) ) THEN
198 info = -4
199 ELSE IF( min( 1, n / 2 ).GT.cutpnt .OR. ( n / 2 ).LT.cutpnt ) THEN
200 info = -7
201 END IF
202 IF( info.NE.0 ) THEN
203 CALL xerbla( 'SLAED1', -info )
204 RETURN
205 END IF
206*
207* Quick return if possible
208*
209 IF( n.EQ.0 )
210 $ RETURN
211*
212* The following values are integer pointers which indicate
213* the portion of the workspace
214* used by a particular array in SLAED2 and SLAED3.
215*
216 iz = 1
217 idlmda = iz + n
218 iw = idlmda + n
219 iq2 = iw + n
220*
221 indx = 1
222 indxc = indx + n
223 coltyp = indxc + n
224 indxp = coltyp + n
225*
226*
227* Form the z-vector which consists of the last row of Q_1 and the
228* first row of Q_2.
229*
230 CALL scopy( cutpnt, q( cutpnt, 1 ), ldq, work( iz ), 1 )
231 cpp1 = cutpnt + 1
232 CALL scopy( n-cutpnt, q( cpp1, cpp1 ), ldq, work( iz+cutpnt ), 1 )
233*
234* Deflate eigenvalues.
235*
236 CALL slaed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ),
237 $ work( idlmda ), work( iw ), work( iq2 ),
238 $ iwork( indx ), iwork( indxc ), iwork( indxp ),
239 $ iwork( coltyp ), info )
240*
241 IF( info.NE.0 )
242 $ GO TO 20
243*
244* Solve Secular Equation.
245*
246 IF( k.NE.0 ) THEN
247 is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt +
248 $ ( iwork( coltyp+1 )+iwork( coltyp+2 ) )*( n-cutpnt ) + iq2
249 CALL slaed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ),
250 $ work( iq2 ), iwork( indxc ), iwork( coltyp ),
251 $ work( iw ), work( is ), info )
252 IF( info.NE.0 )
253 $ GO TO 20
254*
255* Prepare the INDXQ sorting permutation.
256*
257 n1 = k
258 n2 = n - k
259 CALL slamrg( n1, n2, d, 1, -1, indxq )
260 ELSE
261 DO 10 i = 1, n
262 indxq( i ) = i
263 10 CONTINUE
264 END IF
265*
266 20 CONTINUE
267 RETURN
268*
269* End of SLAED1
270*
slaed3
subroutine slaed3(k, n, n1, d, q, ldq, rho, dlamda, q2, indx, ctot, w, s, info)
SLAED3 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors....
Definition slaed3.f:185
slamrg
subroutine slamrg(n1, n2, a, strd1, strd2, index)
SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single...
Definition slamrg.f:99
slaed2
subroutine slaed2(k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, info)
SLAED2 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matri...
Definition slaed2.f:212

◆ slaed2()

subroutine slaed2 ( integer k,
integer n,
integer n1,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
real rho,
real, dimension( * ) z,
real, dimension( * ) dlamda,
real, dimension( * ) w,
real, dimension( * ) q2,
integer, dimension( * ) indx,
integer, dimension( * ) indxc,
integer, dimension( * ) indxp,
integer, dimension( * ) coltyp,
integer info )

SLAED2 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> SLAED2 merges the two sets of eigenvalues together into a single
!> sorted set.  Then it tries to deflate the size of the problem.
!> There are two ways in which deflation can occur:  when two or more
!> eigenvalues are close together or if there is a tiny entry in the
!> Z vector.  For each such occurrence the order of the related secular
!> equation problem is reduced by one.
!>
Parameters
[out]K
!>          K is INTEGER
!>         The number of non-deflated eigenvalues, and the order of the
!>         related secular equation. 0 <= K <=N.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]N1
!>          N1 is INTEGER
!>         The location of the last eigenvalue in the leading sub-matrix.
!>         min(1,N) <= N1 <= N/2.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>         On entry, D contains the eigenvalues of the two submatrices to
!>         be combined.
!>         On exit, D contains the trailing (N-K) updated eigenvalues
!>         (those which were deflated) sorted into increasing order.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>         On entry, Q contains the eigenvectors of two submatrices in
!>         the two square blocks with corners at (1,1), (N1,N1)
!>         and (N1+1, N1+1), (N,N).
!>         On exit, Q contains the trailing (N-K) updated eigenvectors
!>         (those which were deflated) in its last N-K columns.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in,out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which separately sorts the two sub-problems
!>         in D into ascending order.  Note that elements in the second
!>         half of this permutation must first have N1 added to their
!>         values. Destroyed on exit.
!>
[in,out]RHO
!>          RHO is REAL
!>         On entry, the off-diagonal element associated with the rank-1
!>         cut which originally split the two submatrices which are now
!>         being recombined.
!>         On exit, RHO has been modified to the value required by
!>         SLAED3.
!>
[in]Z
!>          Z is REAL array, dimension (N)
!>         On entry, Z contains the updating vector (the last
!>         row of the first sub-eigenvector matrix and the first row of
!>         the second sub-eigenvector matrix).
!>         On exit, the contents of Z have been destroyed by the updating
!>         process.
!>
[out]DLAMDA
!>          DLAMDA is REAL array, dimension (N)
!>         A copy of the first K eigenvalues which will be used by
!>         SLAED3 to form the secular equation.
!>
[out]W
!>          W is REAL array, dimension (N)
!>         The first k values of the final deflation-altered z-vector
!>         which will be passed to SLAED3.
!>
[out]Q2
!>          Q2 is REAL array, dimension (N1**2+(N-N1)**2)
!>         A copy of the first K eigenvectors which will be used by
!>         SLAED3 in a matrix multiply (SGEMM) to solve for the new
!>         eigenvectors.
!>
[out]INDX
!>          INDX is INTEGER array, dimension (N)
!>         The permutation used to sort the contents of DLAMDA into
!>         ascending order.
!>
[out]INDXC
!>          INDXC is INTEGER array, dimension (N)
!>         The permutation used to arrange the columns of the deflated
!>         Q matrix into three groups:  the first group contains non-zero
!>         elements only at and above N1, the second contains
!>         non-zero elements only below N1, and the third is dense.
!>
[out]INDXP
!>          INDXP is INTEGER array, dimension (N)
!>         The permutation used to place deflated values of D at the end
!>         of the array.  INDXP(1:K) points to the nondeflated D-values
!>         and INDXP(K+1:N) points to the deflated eigenvalues.
!>
[out]COLTYP
!>          COLTYP is INTEGER array, dimension (N)
!>         During execution, a label which will indicate which of the
!>         following types a column in the Q2 matrix is:
!>         1 : non-zero in the upper half only;
!>         2 : dense;
!>         3 : non-zero in the lower half only;
!>         4 : deflated.
!>         On exit, COLTYP(i) is the number of columns of type i,
!>         for i=1 to 4 only.
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 210 of file slaed2.f.

212*
213* -- LAPACK computational routine --
214* -- LAPACK is a software package provided by Univ. of Tennessee, --
215* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216*
217* .. Scalar Arguments ..
218 INTEGER INFO, K, LDQ, N, N1
219 REAL RHO
220* ..
221* .. Array Arguments ..
222 INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
223 $ INDXQ( * )
224 REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
225 $ W( * ), Z( * )
226* ..
227*
228* =====================================================================
229*
230* .. Parameters ..
231 REAL MONE, ZERO, ONE, TWO, EIGHT
232 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
233 $ two = 2.0e0, eight = 8.0e0 )
234* ..
235* .. Local Arrays ..
236 INTEGER CTOT( 4 ), PSM( 4 )
237* ..
238* .. Local Scalars ..
239 INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
240 $ N2, NJ, PJ
241 REAL C, EPS, S, T, TAU, TOL
242* ..
243* .. External Functions ..
244 INTEGER ISAMAX
245 REAL SLAMCH, SLAPY2
246 EXTERNAL isamax, slamch, slapy2
247* ..
248* .. External Subroutines ..
249 EXTERNAL scopy, slacpy, slamrg, srot, sscal, xerbla
250* ..
251* .. Intrinsic Functions ..
252 INTRINSIC abs, max, min, sqrt
253* ..
254* .. Executable Statements ..
255*
256* Test the input parameters.
257*
258 info = 0
259*
260 IF( n.LT.0 ) THEN
261 info = -2
262 ELSE IF( ldq.LT.max( 1, n ) ) THEN
263 info = -6
264 ELSE IF( min( 1, ( n / 2 ) ).GT.n1 .OR. ( n / 2 ).LT.n1 ) THEN
265 info = -3
266 END IF
267 IF( info.NE.0 ) THEN
268 CALL xerbla( 'SLAED2', -info )
269 RETURN
270 END IF
271*
272* Quick return if possible
273*
274 IF( n.EQ.0 )
275 $ RETURN
276*
277 n2 = n - n1
278 n1p1 = n1 + 1
279*
280 IF( rho.LT.zero ) THEN
281 CALL sscal( n2, mone, z( n1p1 ), 1 )
282 END IF
283*
284* Normalize z so that norm(z) = 1. Since z is the concatenation of
285* two normalized vectors, norm2(z) = sqrt(2).
286*
287 t = one / sqrt( two )
288 CALL sscal( n, t, z, 1 )
289*
290* RHO = ABS( norm(z)**2 * RHO )
291*
292 rho = abs( two*rho )
293*
294* Sort the eigenvalues into increasing order
295*
296 DO 10 i = n1p1, n
297 indxq( i ) = indxq( i ) + n1
298 10 CONTINUE
299*
300* re-integrate the deflated parts from the last pass
301*
302 DO 20 i = 1, n
303 dlamda( i ) = d( indxq( i ) )
304 20 CONTINUE
305 CALL slamrg( n1, n2, dlamda, 1, 1, indxc )
306 DO 30 i = 1, n
307 indx( i ) = indxq( indxc( i ) )
308 30 CONTINUE
309*
310* Calculate the allowable deflation tolerance
311*
312 imax = isamax( n, z, 1 )
313 jmax = isamax( n, d, 1 )
314 eps = slamch( 'Epsilon' )
315 tol = eight*eps*max( abs( d( jmax ) ), abs( z( imax ) ) )
316*
317* If the rank-1 modifier is small enough, no more needs to be done
318* except to reorganize Q so that its columns correspond with the
319* elements in D.
320*
321 IF( rho*abs( z( imax ) ).LE.tol ) THEN
322 k = 0
323 iq2 = 1
324 DO 40 j = 1, n
325 i = indx( j )
326 CALL scopy( n, q( 1, i ), 1, q2( iq2 ), 1 )
327 dlamda( j ) = d( i )
328 iq2 = iq2 + n
329 40 CONTINUE
330 CALL slacpy( 'A', n, n, q2, n, q, ldq )
331 CALL scopy( n, dlamda, 1, d, 1 )
332 GO TO 190
333 END IF
334*
335* If there are multiple eigenvalues then the problem deflates. Here
336* the number of equal eigenvalues are found. As each equal
337* eigenvalue is found, an elementary reflector is computed to rotate
338* the corresponding eigensubspace so that the corresponding
339* components of Z are zero in this new basis.
340*
341 DO 50 i = 1, n1
342 coltyp( i ) = 1
343 50 CONTINUE
344 DO 60 i = n1p1, n
345 coltyp( i ) = 3
346 60 CONTINUE
347*
348*
349 k = 0
350 k2 = n + 1
351 DO 70 j = 1, n
352 nj = indx( j )
353 IF( rho*abs( z( nj ) ).LE.tol ) THEN
354*
355* Deflate due to small z component.
356*
357 k2 = k2 - 1
358 coltyp( nj ) = 4
359 indxp( k2 ) = nj
360 IF( j.EQ.n )
361 $ GO TO 100
362 ELSE
363 pj = nj
364 GO TO 80
365 END IF
366 70 CONTINUE
367 80 CONTINUE
368 j = j + 1
369 nj = indx( j )
370 IF( j.GT.n )
371 $ GO TO 100
372 IF( rho*abs( z( nj ) ).LE.tol ) THEN
373*
374* Deflate due to small z component.
375*
376 k2 = k2 - 1
377 coltyp( nj ) = 4
378 indxp( k2 ) = nj
379 ELSE
380*
381* Check if eigenvalues are close enough to allow deflation.
382*
383 s = z( pj )
384 c = z( nj )
385*
386* Find sqrt(a**2+b**2) without overflow or
387* destructive underflow.
388*
389 tau = slapy2( c, s )
390 t = d( nj ) - d( pj )
391 c = c / tau
392 s = -s / tau
393 IF( abs( t*c*s ).LE.tol ) THEN
394*
395* Deflation is possible.
396*
397 z( nj ) = tau
398 z( pj ) = zero
399 IF( coltyp( nj ).NE.coltyp( pj ) )
400 $ coltyp( nj ) = 2
401 coltyp( pj ) = 4
402 CALL srot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s )
403 t = d( pj )*c**2 + d( nj )*s**2
404 d( nj ) = d( pj )*s**2 + d( nj )*c**2
405 d( pj ) = t
406 k2 = k2 - 1
407 i = 1
408 90 CONTINUE
409 IF( k2+i.LE.n ) THEN
410 IF( d( pj ).LT.d( indxp( k2+i ) ) ) THEN
411 indxp( k2+i-1 ) = indxp( k2+i )
412 indxp( k2+i ) = pj
413 i = i + 1
414 GO TO 90
415 ELSE
416 indxp( k2+i-1 ) = pj
417 END IF
418 ELSE
419 indxp( k2+i-1 ) = pj
420 END IF
421 pj = nj
422 ELSE
423 k = k + 1
424 dlamda( k ) = d( pj )
425 w( k ) = z( pj )
426 indxp( k ) = pj
427 pj = nj
428 END IF
429 END IF
430 GO TO 80
431 100 CONTINUE
432*
433* Record the last eigenvalue.
434*
435 k = k + 1
436 dlamda( k ) = d( pj )
437 w( k ) = z( pj )
438 indxp( k ) = pj
439*
440* Count up the total number of the various types of columns, then
441* form a permutation which positions the four column types into
442* four uniform groups (although one or more of these groups may be
443* empty).
444*
445 DO 110 j = 1, 4
446 ctot( j ) = 0
447 110 CONTINUE
448 DO 120 j = 1, n
449 ct = coltyp( j )
450 ctot( ct ) = ctot( ct ) + 1
451 120 CONTINUE
452*
453* PSM(*) = Position in SubMatrix (of types 1 through 4)
454*
455 psm( 1 ) = 1
456 psm( 2 ) = 1 + ctot( 1 )
457 psm( 3 ) = psm( 2 ) + ctot( 2 )
458 psm( 4 ) = psm( 3 ) + ctot( 3 )
459 k = n - ctot( 4 )
460*
461* Fill out the INDXC array so that the permutation which it induces
462* will place all type-1 columns first, all type-2 columns next,
463* then all type-3's, and finally all type-4's.
464*
465 DO 130 j = 1, n
466 js = indxp( j )
467 ct = coltyp( js )
468 indx( psm( ct ) ) = js
469 indxc( psm( ct ) ) = j
470 psm( ct ) = psm( ct ) + 1
471 130 CONTINUE
472*
473* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
474* and Q2 respectively. The eigenvalues/vectors which were not
475* deflated go into the first K slots of DLAMDA and Q2 respectively,
476* while those which were deflated go into the last N - K slots.
477*
478 i = 1
479 iq1 = 1
480 iq2 = 1 + ( ctot( 1 )+ctot( 2 ) )*n1
481 DO 140 j = 1, ctot( 1 )
482 js = indx( i )
483 CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
484 z( i ) = d( js )
485 i = i + 1
486 iq1 = iq1 + n1
487 140 CONTINUE
488*
489 DO 150 j = 1, ctot( 2 )
490 js = indx( i )
491 CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 )
492 CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
493 z( i ) = d( js )
494 i = i + 1
495 iq1 = iq1 + n1
496 iq2 = iq2 + n2
497 150 CONTINUE
498*
499 DO 160 j = 1, ctot( 3 )
500 js = indx( i )
501 CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 )
502 z( i ) = d( js )
503 i = i + 1
504 iq2 = iq2 + n2
505 160 CONTINUE
506*
507 iq1 = iq2
508 DO 170 j = 1, ctot( 4 )
509 js = indx( i )
510 CALL scopy( n, q( 1, js ), 1, q2( iq2 ), 1 )
511 iq2 = iq2 + n
512 z( i ) = d( js )
513 i = i + 1
514 170 CONTINUE
515*
516* The deflated eigenvalues and their corresponding vectors go back
517* into the last N - K slots of D and Q respectively.
518*
519 IF( k.LT.n ) THEN
520 CALL slacpy( 'A', n, ctot( 4 ), q2( iq1 ), n,
521 $ q( 1, k+1 ), ldq )
522 CALL scopy( n-k, z( k+1 ), 1, d( k+1 ), 1 )
523 END IF
524*
525* Copy CTOT into COLTYP for referencing in SLAED3.
526*
527 DO 180 j = 1, 4
528 coltyp( j ) = ctot( j )
529 180 CONTINUE
530*
531 190 CONTINUE
532 RETURN
533*
534* End of SLAED2
535*
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71

◆ slaed3()

subroutine slaed3 ( integer k,
integer n,
integer n1,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
real rho,
real, dimension( * ) dlamda,
real, dimension( * ) q2,
integer, dimension( * ) indx,
integer, dimension( * ) ctot,
real, dimension( * ) w,
real, dimension( * ) s,
integer info )

SLAED3 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is tridiagonal.

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

Purpose:
!>
!> SLAED3 finds the roots of the secular equation, as defined by the
!> values in D, W, and RHO, between 1 and K.  It makes the
!> appropriate calls to SLAED4 and then updates the eigenvectors by
!> multiplying the matrix of eigenvectors of the pair of eigensystems
!> being combined by the matrix of eigenvectors of the K-by-K system
!> which is solved here.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.
!>
Parameters
[in]K
!>          K is INTEGER
!>          The number of terms in the rational function to be solved by
!>          SLAED4.  K >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns in the Q matrix.
!>          N >= K (deflation may result in N>K).
!>
[in]N1
!>          N1 is INTEGER
!>          The location of the last eigenvalue in the leading submatrix.
!>          min(1,N) <= N1 <= N/2.
!>
[out]D
!>          D is REAL array, dimension (N)
!>          D(I) contains the updated eigenvalues for
!>          1 <= I <= K.
!>
[out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>          Initially the first K columns are used as workspace.
!>          On output the columns 1 to K contain
!>          the updated eigenvectors.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in]RHO
!>          RHO is REAL
!>          The value of the parameter in the rank one update equation.
!>          RHO >= 0 required.
!>
[in,out]DLAMDA
!>          DLAMDA 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. May be changed on output by
!>          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
!>          Cray-2, or Cray C-90, as described above.
!>
[in]Q2
!>          Q2 is REAL array, dimension (LDQ2*N)
!>          The first K columns of this matrix contain the non-deflated
!>          eigenvectors for the split problem.
!>
[in]INDX
!>          INDX is INTEGER array, dimension (N)
!>          The permutation used to arrange the columns of the deflated
!>          Q matrix into three groups (see SLAED2).
!>          The rows of the eigenvectors found by SLAED4 must be likewise
!>          permuted before the matrix multiply can take place.
!>
[in]CTOT
!>          CTOT is INTEGER array, dimension (4)
!>          A count of the total number of the various types of columns
!>          in Q, as described in INDX.  The fourth column type is any
!>          column which has been deflated.
!>
[in,out]W
!>          W is REAL array, dimension (K)
!>          The first K elements of this array contain the components
!>          of the deflation-adjusted updating vector. Destroyed on
!>          output.
!>
[out]S
!>          S is REAL array, dimension (N1 + 1)*K
!>          Will contain the eigenvectors of the repaired matrix which
!>          will be multiplied by the previously accumulated eigenvectors
!>          to update the system.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = 1, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 183 of file slaed3.f.

185*
186* -- LAPACK computational routine --
187* -- LAPACK is a software package provided by Univ. of Tennessee, --
188* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
189*
190* .. Scalar Arguments ..
191 INTEGER INFO, K, LDQ, N, N1
192 REAL RHO
193* ..
194* .. Array Arguments ..
195 INTEGER CTOT( * ), INDX( * )
196 REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
197 $ S( * ), W( * )
198* ..
199*
200* =====================================================================
201*
202* .. Parameters ..
203 REAL ONE, ZERO
204 parameter( one = 1.0e0, zero = 0.0e0 )
205* ..
206* .. Local Scalars ..
207 INTEGER I, II, IQ2, J, N12, N2, N23
208 REAL TEMP
209* ..
210* .. External Functions ..
211 REAL SLAMC3, SNRM2
212 EXTERNAL slamc3, snrm2
213* ..
214* .. External Subroutines ..
215 EXTERNAL scopy, sgemm, slacpy, slaed4, slaset, xerbla
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC max, sign, sqrt
219* ..
220* .. Executable Statements ..
221*
222* Test the input parameters.
223*
224 info = 0
225*
226 IF( k.LT.0 ) THEN
227 info = -1
228 ELSE IF( n.LT.k ) THEN
229 info = -2
230 ELSE IF( ldq.LT.max( 1, n ) ) THEN
231 info = -6
232 END IF
233 IF( info.NE.0 ) THEN
234 CALL xerbla( 'SLAED3', -info )
235 RETURN
236 END IF
237*
238* Quick return if possible
239*
240 IF( k.EQ.0 )
241 $ RETURN
242*
243* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
244* be computed with high relative accuracy (barring over/underflow).
245* This is a problem on machines without a guard digit in
246* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
247* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
248* which on any of these machines zeros out the bottommost
249* bit of DLAMDA(I) if it is 1; this makes the subsequent
250* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
251* occurs. On binary machines with a guard digit (almost all
252* machines) it does not change DLAMDA(I) at all. On hexadecimal
253* and decimal machines with a guard digit, it slightly
254* changes the bottommost bits of DLAMDA(I). It does not account
255* for hexadecimal or decimal machines without guard digits
256* (we know of none). We use a subroutine call to compute
257* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
258* this code.
259*
260 DO 10 i = 1, k
261 dlamda( i ) = slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
262 10 CONTINUE
263*
264 DO 20 j = 1, k
265 CALL slaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info )
266*
267* If the zero finder fails, the computation is terminated.
268*
269 IF( info.NE.0 )
270 $ GO TO 120
271 20 CONTINUE
272*
273 IF( k.EQ.1 )
274 $ GO TO 110
275 IF( k.EQ.2 ) THEN
276 DO 30 j = 1, k
277 w( 1 ) = q( 1, j )
278 w( 2 ) = q( 2, j )
279 ii = indx( 1 )
280 q( 1, j ) = w( ii )
281 ii = indx( 2 )
282 q( 2, j ) = w( ii )
283 30 CONTINUE
284 GO TO 110
285 END IF
286*
287* Compute updated W.
288*
289 CALL scopy( k, w, 1, s, 1 )
290*
291* Initialize W(I) = Q(I,I)
292*
293 CALL scopy( k, q, ldq+1, w, 1 )
294 DO 60 j = 1, k
295 DO 40 i = 1, j - 1
296 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
297 40 CONTINUE
298 DO 50 i = j + 1, k
299 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
300 50 CONTINUE
301 60 CONTINUE
302 DO 70 i = 1, k
303 w( i ) = sign( sqrt( -w( i ) ), s( i ) )
304 70 CONTINUE
305*
306* Compute eigenvectors of the modified rank-1 modification.
307*
308 DO 100 j = 1, k
309 DO 80 i = 1, k
310 s( i ) = w( i ) / q( i, j )
311 80 CONTINUE
312 temp = snrm2( k, s, 1 )
313 DO 90 i = 1, k
314 ii = indx( i )
315 q( i, j ) = s( ii ) / temp
316 90 CONTINUE
317 100 CONTINUE
318*
319* Compute the updated eigenvectors.
320*
321 110 CONTINUE
322*
323 n2 = n - n1
324 n12 = ctot( 1 ) + ctot( 2 )
325 n23 = ctot( 2 ) + ctot( 3 )
326*
327 CALL slacpy( 'A', n23, k, q( ctot( 1 )+1, 1 ), ldq, s, n23 )
328 iq2 = n1*n12 + 1
329 IF( n23.NE.0 ) THEN
330 CALL sgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23,
331 $ zero, q( n1+1, 1 ), ldq )
332 ELSE
333 CALL slaset( 'A', n2, k, zero, zero, q( n1+1, 1 ), ldq )
334 END IF
335*
336 CALL slacpy( 'A', n12, k, q, ldq, s, n12 )
337 IF( n12.NE.0 ) THEN
338 CALL sgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q,
339 $ ldq )
340 ELSE
341 CALL slaset( 'A', n1, k, zero, zero, q( 1, 1 ), ldq )
342 END IF
343*
344*
345 120 CONTINUE
346 RETURN
347*
348* End of SLAED3
349*
slaed4
subroutine slaed4(n, i, d, z, delta, rho, dlam, info)
SLAED4 used by SSTEDC. Finds a single root of the secular equation.
Definition slaed4.f:145
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89
slamc3
real function slamc3(a, b)
SLAMC3
Definition slamch.f:169

◆ slaed4()

subroutine slaed4 ( integer n,
integer i,
real, dimension( * ) d,
real, dimension( * ) z,
real, dimension( * ) delta,
real rho,
real dlam,
integer info )

SLAED4 used by SSTEDC. Finds a single root of the secular equation.

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

Purpose:
!>
!> This subroutine computes the I-th updated eigenvalue of a symmetric
!> rank-one modification to a diagonal matrix whose elements are
!> given in the array d, and that
!>
!>            D(i) < D(j)  for  i < j
!>
!> and that RHO > 0.  This is arranged by the calling routine, and is
!> no loss in generality.  The rank-one modified system is thus
!>
!>            diag( D )  +  RHO * Z * Z_transpose.
!>
!> where we assume the Euclidean norm of Z is 1.
!>
!> The method consists of approximating the rational functions in the
!> secular equation by simpler interpolating rational functions.
!>
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, 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 > 2, DELTA contains (D(j) - lambda_I) in its  j-th
!>         component.  If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5
!>         for detail. The vector DELTA contains the information necessary
!>         to construct the eigenvectors by SLAED3 and SLAED9.
!>
[in]RHO
!>          RHO is REAL
!>         The scalar in the symmetric updating formula.
!>
[out]DLAM
!>          DLAM is REAL
!>         The computed lambda_I, the I-th updated eigenvalue.
!>
[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 144 of file slaed4.f.

145*
146* -- LAPACK computational routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER I, INFO, N
152 REAL DLAM, RHO
153* ..
154* .. Array Arguments ..
155 REAL D( * ), DELTA( * ), Z( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 INTEGER MAXIT
162 parameter( maxit = 30 )
163 REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
164 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
165 $ three = 3.0e0, four = 4.0e0, eight = 8.0e0,
166 $ ten = 10.0e0 )
167* ..
168* .. Local Scalars ..
169 LOGICAL ORGATI, SWTCH, SWTCH3
170 INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
171 REAL A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
172 $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
173 $ RHOINV, TAU, TEMP, TEMP1, W
174* ..
175* .. Local Arrays ..
176 REAL ZZ( 3 )
177* ..
178* .. External Functions ..
179 REAL SLAMCH
180 EXTERNAL slamch
181* ..
182* .. External Subroutines ..
183 EXTERNAL slaed5, slaed6
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, max, min, sqrt
187* ..
188* .. Executable Statements ..
189*
190* Since this routine is called in an inner loop, we do no argument
191* checking.
192*
193* Quick return for N=1 and 2.
194*
195 info = 0
196 IF( n.EQ.1 ) THEN
197*
198* Presumably, I=1 upon entry
199*
200 dlam = d( 1 ) + rho*z( 1 )*z( 1 )
201 delta( 1 ) = one
202 RETURN
203 END IF
204 IF( n.EQ.2 ) THEN
205 CALL slaed5( i, d, z, delta, rho, dlam )
206 RETURN
207 END IF
208*
209* Compute machine epsilon
210*
211 eps = slamch( 'Epsilon' )
212 rhoinv = one / rho
213*
214* The case I = N
215*
216 IF( i.EQ.n ) THEN
217*
218* Initialize some basic variables
219*
220 ii = n - 1
221 niter = 1
222*
223* Calculate initial guess
224*
225 midpt = rho / two
226*
227* If ||Z||_2 is not one, then TEMP should be set to
228* RHO * ||Z||_2^2 / TWO
229*
230 DO 10 j = 1, n
231 delta( j ) = ( d( j )-d( i ) ) - midpt
232 10 CONTINUE
233*
234 psi = zero
235 DO 20 j = 1, n - 2
236 psi = psi + z( j )*z( j ) / delta( j )
237 20 CONTINUE
238*
239 c = rhoinv + psi
240 w = c + z( ii )*z( ii ) / delta( ii ) +
241 $ z( n )*z( n ) / delta( n )
242*
243 IF( w.LE.zero ) THEN
244 temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) +
245 $ z( n )*z( n ) / rho
246 IF( c.LE.temp ) THEN
247 tau = rho
248 ELSE
249 del = d( n ) - d( n-1 )
250 a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
251 b = z( n )*z( n )*del
252 IF( a.LT.zero ) THEN
253 tau = two*b / ( sqrt( a*a+four*b*c )-a )
254 ELSE
255 tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
256 END IF
257 END IF
258*
259* It can be proved that
260* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
261*
262 dltlb = midpt
263 dltub = rho
264 ELSE
265 del = d( n ) - d( n-1 )
266 a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n )
267 b = z( n )*z( n )*del
268 IF( a.LT.zero ) THEN
269 tau = two*b / ( sqrt( a*a+four*b*c )-a )
270 ELSE
271 tau = ( a+sqrt( a*a+four*b*c ) ) / ( two*c )
272 END IF
273*
274* It can be proved that
275* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
276*
277 dltlb = zero
278 dltub = midpt
279 END IF
280*
281 DO 30 j = 1, n
282 delta( j ) = ( d( j )-d( i ) ) - tau
283 30 CONTINUE
284*
285* Evaluate PSI and the derivative DPSI
286*
287 dpsi = zero
288 psi = zero
289 erretm = zero
290 DO 40 j = 1, ii
291 temp = z( j ) / delta( j )
292 psi = psi + z( j )*temp
293 dpsi = dpsi + temp*temp
294 erretm = erretm + psi
295 40 CONTINUE
296 erretm = abs( erretm )
297*
298* Evaluate PHI and the derivative DPHI
299*
300 temp = z( n ) / delta( n )
301 phi = z( n )*temp
302 dphi = temp*temp
303 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
304 $ abs( tau )*( dpsi+dphi )
305*
306 w = rhoinv + phi + psi
307*
308* Test for convergence
309*
310 IF( abs( w ).LE.eps*erretm ) THEN
311 dlam = d( i ) + tau
312 GO TO 250
313 END IF
314*
315 IF( w.LE.zero ) THEN
316 dltlb = max( dltlb, tau )
317 ELSE
318 dltub = min( dltub, tau )
319 END IF
320*
321* Calculate the new step
322*
323 niter = niter + 1
324 c = w - delta( n-1 )*dpsi - delta( n )*dphi
325 a = ( delta( n-1 )+delta( n ) )*w -
326 $ delta( n-1 )*delta( n )*( dpsi+dphi )
327 b = delta( n-1 )*delta( n )*w
328 IF( c.LT.zero )
329 $ c = abs( c )
330 IF( c.EQ.zero ) THEN
331* ETA = B/A
332* ETA = RHO - TAU
333 eta = dltub - tau
334 ELSE IF( a.GE.zero ) THEN
335 eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
336 ELSE
337 eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
338 END IF
339*
340* Note, eta should be positive if w is negative, and
341* eta should be negative otherwise. However,
342* if for some reason caused by roundoff, eta*w > 0,
343* we simply use one Newton step instead. This way
344* will guarantee eta*w < 0.
345*
346 IF( w*eta.GT.zero )
347 $ eta = -w / ( dpsi+dphi )
348 temp = tau + eta
349 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
350 IF( w.LT.zero ) THEN
351 eta = ( dltub-tau ) / two
352 ELSE
353 eta = ( dltlb-tau ) / two
354 END IF
355 END IF
356 DO 50 j = 1, n
357 delta( j ) = delta( j ) - eta
358 50 CONTINUE
359*
360 tau = tau + eta
361*
362* Evaluate PSI and the derivative DPSI
363*
364 dpsi = zero
365 psi = zero
366 erretm = zero
367 DO 60 j = 1, ii
368 temp = z( j ) / delta( j )
369 psi = psi + z( j )*temp
370 dpsi = dpsi + temp*temp
371 erretm = erretm + psi
372 60 CONTINUE
373 erretm = abs( erretm )
374*
375* Evaluate PHI and the derivative DPHI
376*
377 temp = z( n ) / delta( n )
378 phi = z( n )*temp
379 dphi = temp*temp
380 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
381 $ abs( tau )*( dpsi+dphi )
382*
383 w = rhoinv + phi + psi
384*
385* Main loop to update the values of the array DELTA
386*
387 iter = niter + 1
388*
389 DO 90 niter = iter, maxit
390*
391* Test for convergence
392*
393 IF( abs( w ).LE.eps*erretm ) THEN
394 dlam = d( i ) + tau
395 GO TO 250
396 END IF
397*
398 IF( w.LE.zero ) THEN
399 dltlb = max( dltlb, tau )
400 ELSE
401 dltub = min( dltub, tau )
402 END IF
403*
404* Calculate the new step
405*
406 c = w - delta( n-1 )*dpsi - delta( n )*dphi
407 a = ( delta( n-1 )+delta( n ) )*w -
408 $ delta( n-1 )*delta( n )*( dpsi+dphi )
409 b = delta( n-1 )*delta( n )*w
410 IF( a.GE.zero ) THEN
411 eta = ( a+sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
412 ELSE
413 eta = two*b / ( a-sqrt( abs( a*a-four*b*c ) ) )
414 END IF
415*
416* Note, eta should be positive if w is negative, and
417* eta should be negative otherwise. However,
418* if for some reason caused by roundoff, eta*w > 0,
419* we simply use one Newton step instead. This way
420* will guarantee eta*w < 0.
421*
422 IF( w*eta.GT.zero )
423 $ eta = -w / ( dpsi+dphi )
424 temp = tau + eta
425 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
426 IF( w.LT.zero ) THEN
427 eta = ( dltub-tau ) / two
428 ELSE
429 eta = ( dltlb-tau ) / two
430 END IF
431 END IF
432 DO 70 j = 1, n
433 delta( j ) = delta( j ) - eta
434 70 CONTINUE
435*
436 tau = tau + eta
437*
438* Evaluate PSI and the derivative DPSI
439*
440 dpsi = zero
441 psi = zero
442 erretm = zero
443 DO 80 j = 1, ii
444 temp = z( j ) / delta( j )
445 psi = psi + z( j )*temp
446 dpsi = dpsi + temp*temp
447 erretm = erretm + psi
448 80 CONTINUE
449 erretm = abs( erretm )
450*
451* Evaluate PHI and the derivative DPHI
452*
453 temp = z( n ) / delta( n )
454 phi = z( n )*temp
455 dphi = temp*temp
456 erretm = eight*( -phi-psi ) + erretm - phi + rhoinv +
457 $ abs( tau )*( dpsi+dphi )
458*
459 w = rhoinv + phi + psi
460 90 CONTINUE
461*
462* Return with INFO = 1, NITER = MAXIT and not converged
463*
464 info = 1
465 dlam = d( i ) + tau
466 GO TO 250
467*
468* End for the case I = N
469*
470 ELSE
471*
472* The case for I < N
473*
474 niter = 1
475 ip1 = i + 1
476*
477* Calculate initial guess
478*
479 del = d( ip1 ) - d( i )
480 midpt = del / two
481 DO 100 j = 1, n
482 delta( j ) = ( d( j )-d( i ) ) - midpt
483 100 CONTINUE
484*
485 psi = zero
486 DO 110 j = 1, i - 1
487 psi = psi + z( j )*z( j ) / delta( j )
488 110 CONTINUE
489*
490 phi = zero
491 DO 120 j = n, i + 2, -1
492 phi = phi + z( j )*z( j ) / delta( j )
493 120 CONTINUE
494 c = rhoinv + psi + phi
495 w = c + z( i )*z( i ) / delta( i ) +
496 $ z( ip1 )*z( ip1 ) / delta( ip1 )
497*
498 IF( w.GT.zero ) THEN
499*
500* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
501*
502* We choose d(i) as origin.
503*
504 orgati = .true.
505 a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 )
506 b = z( i )*z( i )*del
507 IF( a.GT.zero ) THEN
508 tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
509 ELSE
510 tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
511 END IF
512 dltlb = zero
513 dltub = midpt
514 ELSE
515*
516* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
517*
518* We choose d(i+1) as origin.
519*
520 orgati = .false.
521 a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 )
522 b = z( ip1 )*z( ip1 )*del
523 IF( a.LT.zero ) THEN
524 tau = two*b / ( a-sqrt( abs( a*a+four*b*c ) ) )
525 ELSE
526 tau = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c )
527 END IF
528 dltlb = -midpt
529 dltub = zero
530 END IF
531*
532 IF( orgati ) THEN
533 DO 130 j = 1, n
534 delta( j ) = ( d( j )-d( i ) ) - tau
535 130 CONTINUE
536 ELSE
537 DO 140 j = 1, n
538 delta( j ) = ( d( j )-d( ip1 ) ) - tau
539 140 CONTINUE
540 END IF
541 IF( orgati ) THEN
542 ii = i
543 ELSE
544 ii = i + 1
545 END IF
546 iim1 = ii - 1
547 iip1 = ii + 1
548*
549* Evaluate PSI and the derivative DPSI
550*
551 dpsi = zero
552 psi = zero
553 erretm = zero
554 DO 150 j = 1, iim1
555 temp = z( j ) / delta( j )
556 psi = psi + z( j )*temp
557 dpsi = dpsi + temp*temp
558 erretm = erretm + psi
559 150 CONTINUE
560 erretm = abs( erretm )
561*
562* Evaluate PHI and the derivative DPHI
563*
564 dphi = zero
565 phi = zero
566 DO 160 j = n, iip1, -1
567 temp = z( j ) / delta( j )
568 phi = phi + z( j )*temp
569 dphi = dphi + temp*temp
570 erretm = erretm + phi
571 160 CONTINUE
572*
573 w = rhoinv + phi + psi
574*
575* W is the value of the secular function with
576* its ii-th element removed.
577*
578 swtch3 = .false.
579 IF( orgati ) THEN
580 IF( w.LT.zero )
581 $ swtch3 = .true.
582 ELSE
583 IF( w.GT.zero )
584 $ swtch3 = .true.
585 END IF
586 IF( ii.EQ.1 .OR. ii.EQ.n )
587 $ swtch3 = .false.
588*
589 temp = z( ii ) / delta( ii )
590 dw = dpsi + dphi + temp*temp
591 temp = z( ii )*temp
592 w = w + temp
593 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
594 $ three*abs( temp ) + abs( tau )*dw
595*
596* Test for convergence
597*
598 IF( abs( w ).LE.eps*erretm ) THEN
599 IF( orgati ) THEN
600 dlam = d( i ) + tau
601 ELSE
602 dlam = d( ip1 ) + tau
603 END IF
604 GO TO 250
605 END IF
606*
607 IF( w.LE.zero ) THEN
608 dltlb = max( dltlb, tau )
609 ELSE
610 dltub = min( dltub, tau )
611 END IF
612*
613* Calculate the new step
614*
615 niter = niter + 1
616 IF( .NOT.swtch3 ) THEN
617 IF( orgati ) THEN
618 c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*
619 $ ( z( i ) / delta( i ) )**2
620 ELSE
621 c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*
622 $ ( z( ip1 ) / delta( ip1 ) )**2
623 END IF
624 a = ( delta( i )+delta( ip1 ) )*w -
625 $ delta( i )*delta( ip1 )*dw
626 b = delta( i )*delta( ip1 )*w
627 IF( c.EQ.zero ) THEN
628 IF( a.EQ.zero ) THEN
629 IF( orgati ) THEN
630 a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )*
631 $ ( dpsi+dphi )
632 ELSE
633 a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*
634 $ ( dpsi+dphi )
635 END IF
636 END IF
637 eta = b / a
638 ELSE IF( a.LE.zero ) THEN
639 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
640 ELSE
641 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
642 END IF
643 ELSE
644*
645* Interpolation using THREE most relevant poles
646*
647 temp = rhoinv + psi + phi
648 IF( orgati ) THEN
649 temp1 = z( iim1 ) / delta( iim1 )
650 temp1 = temp1*temp1
651 c = temp - delta( iip1 )*( dpsi+dphi ) -
652 $ ( d( iim1 )-d( iip1 ) )*temp1
653 zz( 1 ) = z( iim1 )*z( iim1 )
654 zz( 3 ) = delta( iip1 )*delta( iip1 )*
655 $ ( ( dpsi-temp1 )+dphi )
656 ELSE
657 temp1 = z( iip1 ) / delta( iip1 )
658 temp1 = temp1*temp1
659 c = temp - delta( iim1 )*( dpsi+dphi ) -
660 $ ( d( iip1 )-d( iim1 ) )*temp1
661 zz( 1 ) = delta( iim1 )*delta( iim1 )*
662 $ ( dpsi+( dphi-temp1 ) )
663 zz( 3 ) = z( iip1 )*z( iip1 )
664 END IF
665 zz( 2 ) = z( ii )*z( ii )
666 CALL slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,
667 $ info )
668 IF( info.NE.0 )
669 $ GO TO 250
670 END IF
671*
672* Note, eta should be positive if w is negative, and
673* eta should be negative otherwise. However,
674* if for some reason caused by roundoff, eta*w > 0,
675* we simply use one Newton step instead. This way
676* will guarantee eta*w < 0.
677*
678 IF( w*eta.GE.zero )
679 $ eta = -w / dw
680 temp = tau + eta
681 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
682 IF( w.LT.zero ) THEN
683 eta = ( dltub-tau ) / two
684 ELSE
685 eta = ( dltlb-tau ) / two
686 END IF
687 END IF
688*
689 prew = w
690*
691 DO 180 j = 1, n
692 delta( j ) = delta( j ) - eta
693 180 CONTINUE
694*
695* Evaluate PSI and the derivative DPSI
696*
697 dpsi = zero
698 psi = zero
699 erretm = zero
700 DO 190 j = 1, iim1
701 temp = z( j ) / delta( j )
702 psi = psi + z( j )*temp
703 dpsi = dpsi + temp*temp
704 erretm = erretm + psi
705 190 CONTINUE
706 erretm = abs( erretm )
707*
708* Evaluate PHI and the derivative DPHI
709*
710 dphi = zero
711 phi = zero
712 DO 200 j = n, iip1, -1
713 temp = z( j ) / delta( j )
714 phi = phi + z( j )*temp
715 dphi = dphi + temp*temp
716 erretm = erretm + phi
717 200 CONTINUE
718*
719 temp = z( ii ) / delta( ii )
720 dw = dpsi + dphi + temp*temp
721 temp = z( ii )*temp
722 w = rhoinv + phi + psi + temp
723 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
724 $ three*abs( temp ) + abs( tau+eta )*dw
725*
726 swtch = .false.
727 IF( orgati ) THEN
728 IF( -w.GT.abs( prew ) / ten )
729 $ swtch = .true.
730 ELSE
731 IF( w.GT.abs( prew ) / ten )
732 $ swtch = .true.
733 END IF
734*
735 tau = tau + eta
736*
737* Main loop to update the values of the array DELTA
738*
739 iter = niter + 1
740*
741 DO 240 niter = iter, maxit
742*
743* Test for convergence
744*
745 IF( abs( w ).LE.eps*erretm ) THEN
746 IF( orgati ) THEN
747 dlam = d( i ) + tau
748 ELSE
749 dlam = d( ip1 ) + tau
750 END IF
751 GO TO 250
752 END IF
753*
754 IF( w.LE.zero ) THEN
755 dltlb = max( dltlb, tau )
756 ELSE
757 dltub = min( dltub, tau )
758 END IF
759*
760* Calculate the new step
761*
762 IF( .NOT.swtch3 ) THEN
763 IF( .NOT.swtch ) THEN
764 IF( orgati ) THEN
765 c = w - delta( ip1 )*dw -
766 $ ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )**2
767 ELSE
768 c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*
769 $ ( z( ip1 ) / delta( ip1 ) )**2
770 END IF
771 ELSE
772 temp = z( ii ) / delta( ii )
773 IF( orgati ) THEN
774 dpsi = dpsi + temp*temp
775 ELSE
776 dphi = dphi + temp*temp
777 END IF
778 c = w - delta( i )*dpsi - delta( ip1 )*dphi
779 END IF
780 a = ( delta( i )+delta( ip1 ) )*w -
781 $ delta( i )*delta( ip1 )*dw
782 b = delta( i )*delta( ip1 )*w
783 IF( c.EQ.zero ) THEN
784 IF( a.EQ.zero ) THEN
785 IF( .NOT.swtch ) THEN
786 IF( orgati ) THEN
787 a = z( i )*z( i ) + delta( ip1 )*
788 $ delta( ip1 )*( dpsi+dphi )
789 ELSE
790 a = z( ip1 )*z( ip1 ) +
791 $ delta( i )*delta( i )*( dpsi+dphi )
792 END IF
793 ELSE
794 a = delta( i )*delta( i )*dpsi +
795 $ delta( ip1 )*delta( ip1 )*dphi
796 END IF
797 END IF
798 eta = b / a
799 ELSE IF( a.LE.zero ) THEN
800 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
801 ELSE
802 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
803 END IF
804 ELSE
805*
806* Interpolation using THREE most relevant poles
807*
808 temp = rhoinv + psi + phi
809 IF( swtch ) THEN
810 c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi
811 zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi
812 zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi
813 ELSE
814 IF( orgati ) THEN
815 temp1 = z( iim1 ) / delta( iim1 )
816 temp1 = temp1*temp1
817 c = temp - delta( iip1 )*( dpsi+dphi ) -
818 $ ( d( iim1 )-d( iip1 ) )*temp1
819 zz( 1 ) = z( iim1 )*z( iim1 )
820 zz( 3 ) = delta( iip1 )*delta( iip1 )*
821 $ ( ( dpsi-temp1 )+dphi )
822 ELSE
823 temp1 = z( iip1 ) / delta( iip1 )
824 temp1 = temp1*temp1
825 c = temp - delta( iim1 )*( dpsi+dphi ) -
826 $ ( d( iip1 )-d( iim1 ) )*temp1
827 zz( 1 ) = delta( iim1 )*delta( iim1 )*
828 $ ( dpsi+( dphi-temp1 ) )
829 zz( 3 ) = z( iip1 )*z( iip1 )
830 END IF
831 END IF
832 CALL slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,
833 $ info )
834 IF( info.NE.0 )
835 $ GO TO 250
836 END IF
837*
838* Note, eta should be positive if w is negative, and
839* eta should be negative otherwise. However,
840* if for some reason caused by roundoff, eta*w > 0,
841* we simply use one Newton step instead. This way
842* will guarantee eta*w < 0.
843*
844 IF( w*eta.GE.zero )
845 $ eta = -w / dw
846 temp = tau + eta
847 IF( temp.GT.dltub .OR. temp.LT.dltlb ) THEN
848 IF( w.LT.zero ) THEN
849 eta = ( dltub-tau ) / two
850 ELSE
851 eta = ( dltlb-tau ) / two
852 END IF
853 END IF
854*
855 DO 210 j = 1, n
856 delta( j ) = delta( j ) - eta
857 210 CONTINUE
858*
859 tau = tau + eta
860 prew = w
861*
862* Evaluate PSI and the derivative DPSI
863*
864 dpsi = zero
865 psi = zero
866 erretm = zero
867 DO 220 j = 1, iim1
868 temp = z( j ) / delta( j )
869 psi = psi + z( j )*temp
870 dpsi = dpsi + temp*temp
871 erretm = erretm + psi
872 220 CONTINUE
873 erretm = abs( erretm )
874*
875* Evaluate PHI and the derivative DPHI
876*
877 dphi = zero
878 phi = zero
879 DO 230 j = n, iip1, -1
880 temp = z( j ) / delta( j )
881 phi = phi + z( j )*temp
882 dphi = dphi + temp*temp
883 erretm = erretm + phi
884 230 CONTINUE
885*
886 temp = z( ii ) / delta( ii )
887 dw = dpsi + dphi + temp*temp
888 temp = z( ii )*temp
889 w = rhoinv + phi + psi + temp
890 erretm = eight*( phi-psi ) + erretm + two*rhoinv +
891 $ three*abs( temp ) + abs( tau )*dw
892 IF( w*prew.GT.zero .AND. abs( w ).GT.abs( prew ) / ten )
893 $ swtch = .NOT.swtch
894*
895 240 CONTINUE
896*
897* Return with INFO = 1, NITER = MAXIT and not converged
898*
899 info = 1
900 IF( orgati ) THEN
901 dlam = d( i ) + tau
902 ELSE
903 dlam = d( ip1 ) + tau
904 END IF
905*
906 END IF
907*
908 250 CONTINUE
909*
910 RETURN
911*
912* End of SLAED4
913*
slaed6
subroutine slaed6(kniter, orgati, rho, d, z, finit, tau, info)
SLAED6 used by SSTEDC. Computes one Newton step in solution of the secular equation.
Definition slaed6.f:140
slaed5
subroutine slaed5(i, d, z, delta, rho, dlam)
SLAED5 used by SSTEDC. Solves the 2-by-2 secular equation.
Definition slaed5.f:108

◆ slaed5()

subroutine slaed5 ( integer i,
real, dimension( 2 ) d,
real, dimension( 2 ) z,
real, dimension( 2 ) delta,
real rho,
real dlam )

SLAED5 used by SSTEDC. Solves the 2-by-2 secular equation.

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

Purpose:
!>
!> This subroutine computes the I-th eigenvalue of a symmetric rank-one
!> modification of a 2-by-2 diagonal matrix
!>
!>            diag( D )  +  RHO * Z * transpose(Z) .
!>
!> The diagonal elements in the array D are assumed to satisfy
!>
!>            D(i) < D(j)  for  i < j .
!>
!> We also assume RHO > 0 and that the Euclidean norm of the vector
!> Z is one.
!>
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 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)
!>         The vector DELTA contains the information necessary
!>         to construct the eigenvectors.
!>
[in]RHO
!>          RHO is REAL
!>         The scalar in the symmetric updating formula.
!>
[out]DLAM
!>          DLAM is REAL
!>         The computed lambda_I, the I-th updated 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 107 of file slaed5.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER I
115 REAL DLAM, RHO
116* ..
117* .. Array Arguments ..
118 REAL D( 2 ), DELTA( 2 ), Z( 2 )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 REAL ZERO, ONE, TWO, FOUR
125 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
126 $ four = 4.0e0 )
127* ..
128* .. Local Scalars ..
129 REAL B, C, DEL, TAU, TEMP, W
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, sqrt
133* ..
134* .. Executable Statements ..
135*
136 del = d( 2 ) - d( 1 )
137 IF( i.EQ.1 ) THEN
138 w = one + two*rho*( z( 2 )*z( 2 )-z( 1 )*z( 1 ) ) / del
139 IF( w.GT.zero ) THEN
140 b = del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
141 c = rho*z( 1 )*z( 1 )*del
142*
143* B > ZERO, always
144*
145 tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) )
146 dlam = d( 1 ) + tau
147 delta( 1 ) = -z( 1 ) / tau
148 delta( 2 ) = z( 2 ) / ( del-tau )
149 ELSE
150 b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
151 c = rho*z( 2 )*z( 2 )*del
152 IF( b.GT.zero ) THEN
153 tau = -two*c / ( b+sqrt( b*b+four*c ) )
154 ELSE
155 tau = ( b-sqrt( b*b+four*c ) ) / two
156 END IF
157 dlam = d( 2 ) + tau
158 delta( 1 ) = -z( 1 ) / ( del+tau )
159 delta( 2 ) = -z( 2 ) / tau
160 END IF
161 temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) )
162 delta( 1 ) = delta( 1 ) / temp
163 delta( 2 ) = delta( 2 ) / temp
164 ELSE
165*
166* Now I=2
167*
168 b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) )
169 c = rho*z( 2 )*z( 2 )*del
170 IF( b.GT.zero ) THEN
171 tau = ( b+sqrt( b*b+four*c ) ) / two
172 ELSE
173 tau = two*c / ( -b+sqrt( b*b+four*c ) )
174 END IF
175 dlam = d( 2 ) + tau
176 delta( 1 ) = -z( 1 ) / ( del+tau )
177 delta( 2 ) = -z( 2 ) / tau
178 temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) )
179 delta( 1 ) = delta( 1 ) / temp
180 delta( 2 ) = delta( 2 ) / temp
181 END IF
182 RETURN
183*
184* End of SLAED5
185*

◆ slaed6()

subroutine slaed6 ( integer kniter,
logical orgati,
real rho,
real, dimension( 3 ) d,
real, dimension( 3 ) z,
real finit,
real tau,
integer info )

SLAED6 used by SSTEDC. Computes one Newton step in solution of the secular equation.

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

Purpose:
!>
!> SLAED6 computes the positive or negative root (closest to the origin)
!> of
!>                  z(1)        z(2)        z(3)
!> f(x) =   rho + --------- + ---------- + ---------
!>                 d(1)-x      d(2)-x      d(3)-x
!>
!> It is assumed that
!>
!>       if ORGATI = .true. the root is between d(2) and d(3);
!>       otherwise it is between d(1) and d(2)
!>
!> This routine will be called by SLAED4 when necessary. In most cases,
!> the root sought is the smallest in magnitude, though it might not be
!> in some extremely rare situations.
!>
Parameters
[in]KNITER
!>          KNITER is INTEGER
!>               Refer to SLAED4 for its significance.
!>
[in]ORGATI
!>          ORGATI is LOGICAL
!>               If ORGATI is true, the needed root is between d(2) and
!>               d(3); otherwise it is between d(1) and d(2).  See
!>               SLAED4 for further details.
!>
[in]RHO
!>          RHO is REAL
!>               Refer to the equation f(x) above.
!>
[in]D
!>          D is REAL array, dimension (3)
!>               D satisfies d(1) < d(2) < d(3).
!>
[in]Z
!>          Z is REAL array, dimension (3)
!>               Each of the elements in z must be positive.
!>
[in]FINIT
!>          FINIT is REAL
!>               The value of f at 0. It is more accurate than the one
!>               evaluated inside this routine (if someone wants to do
!>               so).
!>
[out]TAU
!>          TAU is REAL
!>               The root of the equation f(x).
!>
[out]INFO
!>          INFO is INTEGER
!>               = 0: successful exit
!>               > 0: if INFO = 1, failure to converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  10/02/03: This version has a few statements commented out for thread
!>  safety (machine parameters are computed on each entry). SJH.
!>
!>  05/10/06: Modified from a new version of Ren-Cang Li, use
!>     Gragg-Thornton-Warner cubic convergent scheme for better stability.
!>
Contributors:
Ren-Cang Li, Computer Science Division, University of California at Berkeley, USA

Definition at line 139 of file slaed6.f.

140*
141* -- LAPACK computational routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 LOGICAL ORGATI
147 INTEGER INFO, KNITER
148 REAL FINIT, RHO, TAU
149* ..
150* .. Array Arguments ..
151 REAL D( 3 ), Z( 3 )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 INTEGER MAXIT
158 parameter( maxit = 40 )
159 REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT
160 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
161 $ three = 3.0e0, four = 4.0e0, eight = 8.0e0 )
162* ..
163* .. External Functions ..
164 REAL SLAMCH
165 EXTERNAL slamch
166* ..
167* .. Local Arrays ..
168 REAL DSCALE( 3 ), ZSCALE( 3 )
169* ..
170* .. Local Scalars ..
171 LOGICAL SCALE
172 INTEGER I, ITER, NITER
173 REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
174 $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
175 $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
176 $ LBD, UBD
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC abs, int, log, max, min, sqrt
180* ..
181* .. Executable Statements ..
182*
183 info = 0
184*
185 IF( orgati ) THEN
186 lbd = d(2)
187 ubd = d(3)
188 ELSE
189 lbd = d(1)
190 ubd = d(2)
191 END IF
192 IF( finit .LT. zero )THEN
193 lbd = zero
194 ELSE
195 ubd = zero
196 END IF
197*
198 niter = 1
199 tau = zero
200 IF( kniter.EQ.2 ) THEN
201 IF( orgati ) THEN
202 temp = ( d( 3 )-d( 2 ) ) / two
203 c = rho + z( 1 ) / ( ( d( 1 )-d( 2 ) )-temp )
204 a = c*( d( 2 )+d( 3 ) ) + z( 2 ) + z( 3 )
205 b = c*d( 2 )*d( 3 ) + z( 2 )*d( 3 ) + z( 3 )*d( 2 )
206 ELSE
207 temp = ( d( 1 )-d( 2 ) ) / two
208 c = rho + z( 3 ) / ( ( d( 3 )-d( 2 ) )-temp )
209 a = c*( d( 1 )+d( 2 ) ) + z( 1 ) + z( 2 )
210 b = c*d( 1 )*d( 2 ) + z( 1 )*d( 2 ) + z( 2 )*d( 1 )
211 END IF
212 temp = max( abs( a ), abs( b ), abs( c ) )
213 a = a / temp
214 b = b / temp
215 c = c / temp
216 IF( c.EQ.zero ) THEN
217 tau = b / a
218 ELSE IF( a.LE.zero ) THEN
219 tau = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
220 ELSE
221 tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
222 END IF
223 IF( tau .LT. lbd .OR. tau .GT. ubd )
224 $ tau = ( lbd+ubd )/two
225 IF( d(1).EQ.tau .OR. d(2).EQ.tau .OR. d(3).EQ.tau ) THEN
226 tau = zero
227 ELSE
228 temp = finit + tau*z(1)/( d(1)*( d( 1 )-tau ) ) +
229 $ tau*z(2)/( d(2)*( d( 2 )-tau ) ) +
230 $ tau*z(3)/( d(3)*( d( 3 )-tau ) )
231 IF( temp .LE. zero )THEN
232 lbd = tau
233 ELSE
234 ubd = tau
235 END IF
236 IF( abs( finit ).LE.abs( temp ) )
237 $ tau = zero
238 END IF
239 END IF
240*
241* get machine parameters for possible scaling to avoid overflow
242*
243* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
244* SMINV2, EPS are not SAVEd anymore between one call to the
245* others but recomputed at each call
246*
247 eps = slamch( 'Epsilon' )
248 base = slamch( 'Base' )
249 small1 = base**( int( log( slamch( 'SafMin' ) ) / log( base ) /
250 $ three ) )
251 sminv1 = one / small1
252 small2 = small1*small1
253 sminv2 = sminv1*sminv1
254*
255* Determine if scaling of inputs necessary to avoid overflow
256* when computing 1/TEMP**3
257*
258 IF( orgati ) THEN
259 temp = min( abs( d( 2 )-tau ), abs( d( 3 )-tau ) )
260 ELSE
261 temp = min( abs( d( 1 )-tau ), abs( d( 2 )-tau ) )
262 END IF
263 scale = .false.
264 IF( temp.LE.small1 ) THEN
265 scale = .true.
266 IF( temp.LE.small2 ) THEN
267*
268* Scale up by power of radix nearest 1/SAFMIN**(2/3)
269*
270 sclfac = sminv2
271 sclinv = small2
272 ELSE
273*
274* Scale up by power of radix nearest 1/SAFMIN**(1/3)
275*
276 sclfac = sminv1
277 sclinv = small1
278 END IF
279*
280* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
281*
282 DO 10 i = 1, 3
283 dscale( i ) = d( i )*sclfac
284 zscale( i ) = z( i )*sclfac
285 10 CONTINUE
286 tau = tau*sclfac
287 lbd = lbd*sclfac
288 ubd = ubd*sclfac
289 ELSE
290*
291* Copy D and Z to DSCALE and ZSCALE
292*
293 DO 20 i = 1, 3
294 dscale( i ) = d( i )
295 zscale( i ) = z( i )
296 20 CONTINUE
297 END IF
298*
299 fc = zero
300 df = zero
301 ddf = zero
302 DO 30 i = 1, 3
303 temp = one / ( dscale( i )-tau )
304 temp1 = zscale( i )*temp
305 temp2 = temp1*temp
306 temp3 = temp2*temp
307 fc = fc + temp1 / dscale( i )
308 df = df + temp2
309 ddf = ddf + temp3
310 30 CONTINUE
311 f = finit + tau*fc
312*
313 IF( abs( f ).LE.zero )
314 $ GO TO 60
315 IF( f .LE. zero )THEN
316 lbd = tau
317 ELSE
318 ubd = tau
319 END IF
320*
321* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
322* scheme
323*
324* It is not hard to see that
325*
326* 1) Iterations will go up monotonically
327* if FINIT < 0;
328*
329* 2) Iterations will go down monotonically
330* if FINIT > 0.
331*
332 iter = niter + 1
333*
334 DO 50 niter = iter, maxit
335*
336 IF( orgati ) THEN
337 temp1 = dscale( 2 ) - tau
338 temp2 = dscale( 3 ) - tau
339 ELSE
340 temp1 = dscale( 1 ) - tau
341 temp2 = dscale( 2 ) - tau
342 END IF
343 a = ( temp1+temp2 )*f - temp1*temp2*df
344 b = temp1*temp2*f
345 c = f - ( temp1+temp2 )*df + temp1*temp2*ddf
346 temp = max( abs( a ), abs( b ), abs( c ) )
347 a = a / temp
348 b = b / temp
349 c = c / temp
350 IF( c.EQ.zero ) THEN
351 eta = b / a
352 ELSE IF( a.LE.zero ) THEN
353 eta = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c )
354 ELSE
355 eta = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) )
356 END IF
357 IF( f*eta.GE.zero ) THEN
358 eta = -f / df
359 END IF
360*
361 tau = tau + eta
362 IF( tau .LT. lbd .OR. tau .GT. ubd )
363 $ tau = ( lbd + ubd )/two
364*
365 fc = zero
366 erretm = zero
367 df = zero
368 ddf = zero
369 DO 40 i = 1, 3
370 IF ( ( dscale( i )-tau ).NE.zero ) THEN
371 temp = one / ( dscale( i )-tau )
372 temp1 = zscale( i )*temp
373 temp2 = temp1*temp
374 temp3 = temp2*temp
375 temp4 = temp1 / dscale( i )
376 fc = fc + temp4
377 erretm = erretm + abs( temp4 )
378 df = df + temp2
379 ddf = ddf + temp3
380 ELSE
381 GO TO 60
382 END IF
383 40 CONTINUE
384 f = finit + tau*fc
385 erretm = eight*( abs( finit )+abs( tau )*erretm ) +
386 $ abs( tau )*df
387 IF( ( abs( f ).LE.four*eps*erretm ) .OR.
388 $ ( (ubd-lbd).LE.four*eps*abs(tau) ) )
389 $ GO TO 60
390 IF( f .LE. zero )THEN
391 lbd = tau
392 ELSE
393 ubd = tau
394 END IF
395 50 CONTINUE
396 info = 1
397 60 CONTINUE
398*
399* Undo scaling
400*
401 IF( scale )
402 $ tau = tau*sclinv
403 RETURN
404*
405* End of SLAED6
406*

◆ slaed7()

subroutine slaed7 ( integer icompq,
integer n,
integer qsiz,
integer tlvls,
integer curlvl,
integer curpbm,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
real rho,
integer cutpnt,
real, dimension( * ) qstore,
integer, dimension( * ) qptr,
integer, dimension( * ) prmptr,
integer, dimension( * ) perm,
integer, dimension( * ) givptr,
integer, dimension( 2, * ) givcol,
real, dimension( 2, * ) givnum,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SLAED7 used by SSTEDC. Computes the updated eigensystem of a diagonal matrix after modification by a rank-one symmetric matrix. Used when the original matrix is dense.

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

Purpose:
!>
!> SLAED7 computes the updated eigensystem of a diagonal
!> matrix after modification by a rank-one symmetric matrix. This
!> routine is used only for the eigenproblem which requires all
!> eigenvalues and optionally eigenvectors of a dense symmetric matrix
!> that has been reduced to tridiagonal form.  SLAED1 handles
!> the case in which all eigenvalues and eigenvectors of a symmetric
!> tridiagonal matrix are desired.
!>
!>   T = Q(in) ( D(in) + RHO * Z*Z**T ) Q**T(in) = Q(out) * D(out) * Q**T(out)
!>
!>    where Z = Q**Tu, u is a vector of length N with ones in the
!>    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
!>
!>    The eigenvectors of the original matrix are stored in Q, and the
!>    eigenvalues are in D.  The algorithm consists of three stages:
!>
!>       The first stage consists of deflating the size of the problem
!>       when there are multiple eigenvalues or if there is a zero in
!>       the Z vector.  For each such occurrence the dimension of the
!>       secular equation problem is reduced by one.  This stage is
!>       performed by the routine SLAED8.
!>
!>       The second stage consists of calculating the updated
!>       eigenvalues. This is done by finding the roots of the secular
!>       equation via the routine SLAED4 (as called by SLAED9).
!>       This routine also calculates the eigenvectors of the current
!>       problem.
!>
!>       The final stage consists of computing the updated eigenvectors
!>       directly using the updated eigenvalues.  The eigenvectors for
!>       the current problem are multiplied with the eigenvectors from
!>       the overall problem.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in]TLVLS
!>          TLVLS is INTEGER
!>         The total number of merging levels in the overall divide and
!>         conquer tree.
!>
[in]CURLVL
!>          CURLVL is INTEGER
!>         The current level in the overall merge routine,
!>         0 <= CURLVL <= TLVLS.
!>
[in]CURPBM
!>          CURPBM is INTEGER
!>         The current problem in the current level in the overall
!>         merge routine (counting from upper left to lower right).
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>         On entry, the eigenvalues of the rank-1-perturbed matrix.
!>         On exit, the eigenvalues of the repaired matrix.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ, N)
!>         On entry, the eigenvectors of the rank-1-perturbed matrix.
!>         On exit, the eigenvectors of the repaired tridiagonal matrix.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[out]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which will reintegrate the subproblem just
!>         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
!>         will be in ascending order.
!>
[in]RHO
!>          RHO is REAL
!>         The subdiagonal element used to create the rank-1
!>         modification.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         Contains the location of the last eigenvalue in the leading
!>         sub-matrix.  min(1,N) <= CUTPNT <= N.
!>
[in,out]QSTORE
!>          QSTORE is REAL array, dimension (N**2+1)
!>         Stores eigenvectors of submatrices encountered during
!>         divide and conquer, packed together. QPTR points to
!>         beginning of the submatrices.
!>
[in,out]QPTR
!>          QPTR is INTEGER array, dimension (N+2)
!>         List of indices pointing to beginning of submatrices stored
!>         in QSTORE. The submatrices are numbered starting at the
!>         bottom left of the divide and conquer tree, from left to
!>         right and bottom to top.
!>
[in]PRMPTR
!>          PRMPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in PERM a
!>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!>         indicates the size of the permutation and also the size of
!>         the full, non-deflated problem.
!>
[in]PERM
!>          PERM is INTEGER array, dimension (N lg N)
!>         Contains the permutations (from deflation and sorting) to be
!>         applied to each eigenblock.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in GIVCOL a
!>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!>         indicates the number of Givens rotations.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N lg N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[in]GIVNUM
!>          GIVNUM is REAL array, dimension (2, N lg N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[out]WORK
!>          WORK is REAL array, dimension (3*N+2*QSIZ*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (4*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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 256 of file slaed7.f.

260*
261* -- LAPACK computational routine --
262* -- LAPACK is a software package provided by Univ. of Tennessee, --
263* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
264*
265* .. Scalar Arguments ..
266 INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
267 $ QSIZ, TLVLS
268 REAL RHO
269* ..
270* .. Array Arguments ..
271 INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
272 $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
273 REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
274 $ QSTORE( * ), WORK( * )
275* ..
276*
277* =====================================================================
278*
279* .. Parameters ..
280 REAL ONE, ZERO
281 parameter( one = 1.0e0, zero = 0.0e0 )
282* ..
283* .. Local Scalars ..
284 INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
285 $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
286* ..
287* .. External Subroutines ..
288 EXTERNAL sgemm, slaed8, slaed9, slaeda, slamrg, xerbla
289* ..
290* .. Intrinsic Functions ..
291 INTRINSIC max, min
292* ..
293* .. Executable Statements ..
294*
295* Test the input parameters.
296*
297 info = 0
298*
299 IF( icompq.LT.0 .OR. icompq.GT.1 ) THEN
300 info = -1
301 ELSE IF( n.LT.0 ) THEN
302 info = -2
303 ELSE IF( icompq.EQ.1 .AND. qsiz.LT.n ) THEN
304 info = -3
305 ELSE IF( ldq.LT.max( 1, n ) ) THEN
306 info = -9
307 ELSE IF( min( 1, n ).GT.cutpnt .OR. n.LT.cutpnt ) THEN
308 info = -12
309 END IF
310 IF( info.NE.0 ) THEN
311 CALL xerbla( 'SLAED7', -info )
312 RETURN
313 END IF
314*
315* Quick return if possible
316*
317 IF( n.EQ.0 )
318 $ RETURN
319*
320* The following values are for bookkeeping purposes only. They are
321* integer pointers which indicate the portion of the workspace
322* used by a particular array in SLAED8 and SLAED9.
323*
324 IF( icompq.EQ.1 ) THEN
325 ldq2 = qsiz
326 ELSE
327 ldq2 = n
328 END IF
329*
330 iz = 1
331 idlmda = iz + n
332 iw = idlmda + n
333 iq2 = iw + n
334 is = iq2 + n*ldq2
335*
336 indx = 1
337 indxc = indx + n
338 coltyp = indxc + n
339 indxp = coltyp + n
340*
341* Form the z-vector which consists of the last row of Q_1 and the
342* first row of Q_2.
343*
344 ptr = 1 + 2**tlvls
345 DO 10 i = 1, curlvl - 1
346 ptr = ptr + 2**( tlvls-i )
347 10 CONTINUE
348 curr = ptr + curpbm
349 CALL slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,
350 $ givcol, givnum, qstore, qptr, work( iz ),
351 $ work( iz+n ), info )
352*
353* When solving the final problem, we no longer need the stored data,
354* so we will overwrite the data from this level onto the previously
355* used storage space.
356*
357 IF( curlvl.EQ.tlvls ) THEN
358 qptr( curr ) = 1
359 prmptr( curr ) = 1
360 givptr( curr ) = 1
361 END IF
362*
363* Sort and Deflate eigenvalues.
364*
365 CALL slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt,
366 $ work( iz ), work( idlmda ), work( iq2 ), ldq2,
367 $ work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ),
368 $ givcol( 1, givptr( curr ) ),
369 $ givnum( 1, givptr( curr ) ), iwork( indxp ),
370 $ iwork( indx ), info )
371 prmptr( curr+1 ) = prmptr( curr ) + n
372 givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr )
373*
374* Solve Secular Equation.
375*
376 IF( k.NE.0 ) THEN
377 CALL slaed9( k, 1, k, n, d, work( is ), k, rho, work( idlmda ),
378 $ work( iw ), qstore( qptr( curr ) ), k, info )
379 IF( info.NE.0 )
380 $ GO TO 30
381 IF( icompq.EQ.1 ) THEN
382 CALL sgemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2,
383 $ qstore( qptr( curr ) ), k, zero, q, ldq )
384 END IF
385 qptr( curr+1 ) = qptr( curr ) + k**2
386*
387* Prepare the INDXQ sorting permutation.
388*
389 n1 = k
390 n2 = n - k
391 CALL slamrg( n1, n2, d, 1, -1, indxq )
392 ELSE
393 qptr( curr+1 ) = qptr( curr )
394 DO 20 i = 1, n
395 indxq( i ) = i
396 20 CONTINUE
397 END IF
398*
399 30 CONTINUE
400 RETURN
401*
402* End of SLAED7
403*
slaed8
subroutine slaed8(icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt, z, dlamda, q2, ldq2, w, perm, givptr, givcol, givnum, indxp, indx, info)
SLAED8 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matri...
Definition slaed8.f:243
slaed9
subroutine slaed9(k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, s, lds, info)
SLAED9 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors....
Definition slaed9.f:156
slaeda
subroutine slaeda(n, tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, info)
SLAEDA used by SSTEDC. Computes the Z vector determining the rank-one modification of the diagonal ma...
Definition slaeda.f:166

◆ slaed8()

subroutine slaed8 ( integer icompq,
integer k,
integer n,
integer qsiz,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
integer, dimension( * ) indxq,
real rho,
integer cutpnt,
real, dimension( * ) z,
real, dimension( * ) dlamda,
real, dimension( ldq2, * ) q2,
integer ldq2,
real, dimension( * ) w,
integer, dimension( * ) perm,
integer givptr,
integer, dimension( 2, * ) givcol,
real, dimension( 2, * ) givnum,
integer, dimension( * ) indxp,
integer, dimension( * ) indx,
integer info )

SLAED8 used by SSTEDC. Merges eigenvalues and deflates secular equation. Used when the original matrix is dense.

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

Purpose:
!>
!> SLAED8 merges the two sets of eigenvalues together into a single
!> sorted set.  Then it tries to deflate the size of the problem.
!> There are two ways in which deflation can occur:  when two or more
!> eigenvalues are close together or if there is a tiny element in the
!> Z vector.  For each such occurrence the order of the related secular
!> equation problem is reduced by one.
!>
Parameters
[in]ICOMPQ
!>          ICOMPQ is INTEGER
!>          = 0:  Compute eigenvalues only.
!>          = 1:  Compute eigenvectors of original dense symmetric matrix
!>                also.  On entry, Q contains the orthogonal matrix used
!>                to reduce the original matrix to tridiagonal form.
!>
[out]K
!>          K is INTEGER
!>         The number of non-deflated eigenvalues, and the order of the
!>         related secular equation.
!>
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]QSIZ
!>          QSIZ is INTEGER
!>         The dimension of the orthogonal matrix used to reduce
!>         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>         On entry, the eigenvalues of the two submatrices to be
!>         combined.  On exit, the trailing (N-K) updated eigenvalues
!>         (those which were deflated) sorted into increasing order.
!>
[in,out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>         If ICOMPQ = 0, Q is not referenced.  Otherwise,
!>         on entry, Q contains the eigenvectors of the partially solved
!>         system which has been previously updated in matrix
!>         multiplies with other partially solved eigensystems.
!>         On exit, Q contains the trailing (N-K) updated eigenvectors
!>         (those which were deflated) in its last N-K columns.
!>
[in]LDQ
!>          LDQ is INTEGER
!>         The leading dimension of the array Q.  LDQ >= max(1,N).
!>
[in]INDXQ
!>          INDXQ is INTEGER array, dimension (N)
!>         The permutation which separately sorts the two sub-problems
!>         in D into ascending order.  Note that elements in the second
!>         half of this permutation must first have CUTPNT added to
!>         their values in order to be accurate.
!>
[in,out]RHO
!>          RHO is REAL
!>         On entry, the off-diagonal element associated with the rank-1
!>         cut which originally split the two submatrices which are now
!>         being recombined.
!>         On exit, RHO has been modified to the value required by
!>         SLAED3.
!>
[in]CUTPNT
!>          CUTPNT is INTEGER
!>         The location of the last eigenvalue in the leading
!>         sub-matrix.  min(1,N) <= CUTPNT <= N.
!>
[in]Z
!>          Z is REAL array, dimension (N)
!>         On entry, Z contains the updating vector (the last row of
!>         the first sub-eigenvector matrix and the first row of the
!>         second sub-eigenvector matrix).
!>         On exit, the contents of Z are destroyed by the updating
!>         process.
!>
[out]DLAMDA
!>          DLAMDA is REAL array, dimension (N)
!>         A copy of the first K eigenvalues which will be used by
!>         SLAED3 to form the secular equation.
!>
[out]Q2
!>          Q2 is REAL array, dimension (LDQ2,N)
!>         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,
!>         a copy of the first K eigenvectors which will be used by
!>         SLAED7 in a matrix multiply (SGEMM) to update the new
!>         eigenvectors.
!>
[in]LDQ2
!>          LDQ2 is INTEGER
!>         The leading dimension of the array Q2.  LDQ2 >= max(1,N).
!>
[out]W
!>          W is REAL array, dimension (N)
!>         The first k values of the final deflation-altered z-vector and
!>         will be passed to SLAED3.
!>
[out]PERM
!>          PERM is INTEGER array, dimension (N)
!>         The permutations (from deflation and sorting) to be applied
!>         to each eigenblock.
!>
[out]GIVPTR
!>          GIVPTR is INTEGER
!>         The number of Givens rotations which took place in this
!>         subproblem.
!>
[out]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[out]GIVNUM
!>          GIVNUM is REAL array, dimension (2, N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[out]INDXP
!>          INDXP is INTEGER array, dimension (N)
!>         The permutation used to place deflated values of D at the end
!>         of the array.  INDXP(1:K) points to the nondeflated D-values
!>         and INDXP(K+1:N) points to the deflated eigenvalues.
!>
[out]INDX
!>          INDX is INTEGER array, dimension (N)
!>         The permutation used to sort the contents of D into ascending
!>         order.
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 240 of file slaed8.f.

243*
244* -- LAPACK computational routine --
245* -- LAPACK is a software package provided by Univ. of Tennessee, --
246* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
247*
248* .. Scalar Arguments ..
249 INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
250 $ QSIZ
251 REAL RHO
252* ..
253* .. Array Arguments ..
254 INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
255 $ INDXQ( * ), PERM( * )
256 REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
257 $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
258* ..
259*
260* =====================================================================
261*
262* .. Parameters ..
263 REAL MONE, ZERO, ONE, TWO, EIGHT
264 parameter( mone = -1.0e0, zero = 0.0e0, one = 1.0e0,
265 $ two = 2.0e0, eight = 8.0e0 )
266* ..
267* .. Local Scalars ..
268*
269 INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
270 REAL C, EPS, S, T, TAU, TOL
271* ..
272* .. External Functions ..
273 INTEGER ISAMAX
274 REAL SLAMCH, SLAPY2
275 EXTERNAL isamax, slamch, slapy2
276* ..
277* .. External Subroutines ..
278 EXTERNAL scopy, slacpy, slamrg, srot, sscal, xerbla
279* ..
280* .. Intrinsic Functions ..
281 INTRINSIC abs, max, min, sqrt
282* ..
283* .. Executable Statements ..
284*
285* Test the input parameters.
286*
287 info = 0
288*
289 IF( icompq.LT.0 .OR. icompq.GT.1 ) THEN
290 info = -1
291 ELSE IF( n.LT.0 ) THEN
292 info = -3
293 ELSE IF( icompq.EQ.1 .AND. qsiz.LT.n ) THEN
294 info = -4
295 ELSE IF( ldq.LT.max( 1, n ) ) THEN
296 info = -7
297 ELSE IF( cutpnt.LT.min( 1, n ) .OR. cutpnt.GT.n ) THEN
298 info = -10
299 ELSE IF( ldq2.LT.max( 1, n ) ) THEN
300 info = -14
301 END IF
302 IF( info.NE.0 ) THEN
303 CALL xerbla( 'SLAED8', -info )
304 RETURN
305 END IF
306*
307* Need to initialize GIVPTR to O here in case of quick exit
308* to prevent an unspecified code behavior (usually sigfault)
309* when IWORK array on entry to *stedc is not zeroed
310* (or at least some IWORK entries which used in *laed7 for GIVPTR).
311*
312 givptr = 0
313*
314* Quick return if possible
315*
316 IF( n.EQ.0 )
317 $ RETURN
318*
319 n1 = cutpnt
320 n2 = n - n1
321 n1p1 = n1 + 1
322*
323 IF( rho.LT.zero ) THEN
324 CALL sscal( n2, mone, z( n1p1 ), 1 )
325 END IF
326*
327* Normalize z so that norm(z) = 1
328*
329 t = one / sqrt( two )
330 DO 10 j = 1, n
331 indx( j ) = j
332 10 CONTINUE
333 CALL sscal( n, t, z, 1 )
334 rho = abs( two*rho )
335*
336* Sort the eigenvalues into increasing order
337*
338 DO 20 i = cutpnt + 1, n
339 indxq( i ) = indxq( i ) + cutpnt
340 20 CONTINUE
341 DO 30 i = 1, n
342 dlamda( i ) = d( indxq( i ) )
343 w( i ) = z( indxq( i ) )
344 30 CONTINUE
345 i = 1
346 j = cutpnt + 1
347 CALL slamrg( n1, n2, dlamda, 1, 1, indx )
348 DO 40 i = 1, n
349 d( i ) = dlamda( indx( i ) )
350 z( i ) = w( indx( i ) )
351 40 CONTINUE
352*
353* Calculate the allowable deflation tolerance
354*
355 imax = isamax( n, z, 1 )
356 jmax = isamax( n, d, 1 )
357 eps = slamch( 'Epsilon' )
358 tol = eight*eps*abs( d( jmax ) )
359*
360* If the rank-1 modifier is small enough, no more needs to be done
361* except to reorganize Q so that its columns correspond with the
362* elements in D.
363*
364 IF( rho*abs( z( imax ) ).LE.tol ) THEN
365 k = 0
366 IF( icompq.EQ.0 ) THEN
367 DO 50 j = 1, n
368 perm( j ) = indxq( indx( j ) )
369 50 CONTINUE
370 ELSE
371 DO 60 j = 1, n
372 perm( j ) = indxq( indx( j ) )
373 CALL scopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
374 60 CONTINUE
375 CALL slacpy( 'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ),
376 $ ldq )
377 END IF
378 RETURN
379 END IF
380*
381* If there are multiple eigenvalues then the problem deflates. Here
382* the number of equal eigenvalues are found. As each equal
383* eigenvalue is found, an elementary reflector is computed to rotate
384* the corresponding eigensubspace so that the corresponding
385* components of Z are zero in this new basis.
386*
387 k = 0
388 k2 = n + 1
389 DO 70 j = 1, n
390 IF( rho*abs( z( j ) ).LE.tol ) THEN
391*
392* Deflate due to small z component.
393*
394 k2 = k2 - 1
395 indxp( k2 ) = j
396 IF( j.EQ.n )
397 $ GO TO 110
398 ELSE
399 jlam = j
400 GO TO 80
401 END IF
402 70 CONTINUE
403 80 CONTINUE
404 j = j + 1
405 IF( j.GT.n )
406 $ GO TO 100
407 IF( rho*abs( z( j ) ).LE.tol ) THEN
408*
409* Deflate due to small z component.
410*
411 k2 = k2 - 1
412 indxp( k2 ) = j
413 ELSE
414*
415* Check if eigenvalues are close enough to allow deflation.
416*
417 s = z( jlam )
418 c = z( j )
419*
420* Find sqrt(a**2+b**2) without overflow or
421* destructive underflow.
422*
423 tau = slapy2( c, s )
424 t = d( j ) - d( jlam )
425 c = c / tau
426 s = -s / tau
427 IF( abs( t*c*s ).LE.tol ) THEN
428*
429* Deflation is possible.
430*
431 z( j ) = tau
432 z( jlam ) = zero
433*
434* Record the appropriate Givens rotation
435*
436 givptr = givptr + 1
437 givcol( 1, givptr ) = indxq( indx( jlam ) )
438 givcol( 2, givptr ) = indxq( indx( j ) )
439 givnum( 1, givptr ) = c
440 givnum( 2, givptr ) = s
441 IF( icompq.EQ.1 ) THEN
442 CALL srot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,
443 $ q( 1, indxq( indx( j ) ) ), 1, c, s )
444 END IF
445 t = d( jlam )*c*c + d( j )*s*s
446 d( j ) = d( jlam )*s*s + d( j )*c*c
447 d( jlam ) = t
448 k2 = k2 - 1
449 i = 1
450 90 CONTINUE
451 IF( k2+i.LE.n ) THEN
452 IF( d( jlam ).LT.d( indxp( k2+i ) ) ) THEN
453 indxp( k2+i-1 ) = indxp( k2+i )
454 indxp( k2+i ) = jlam
455 i = i + 1
456 GO TO 90
457 ELSE
458 indxp( k2+i-1 ) = jlam
459 END IF
460 ELSE
461 indxp( k2+i-1 ) = jlam
462 END IF
463 jlam = j
464 ELSE
465 k = k + 1
466 w( k ) = z( jlam )
467 dlamda( k ) = d( jlam )
468 indxp( k ) = jlam
469 jlam = j
470 END IF
471 END IF
472 GO TO 80
473 100 CONTINUE
474*
475* Record the last eigenvalue.
476*
477 k = k + 1
478 w( k ) = z( jlam )
479 dlamda( k ) = d( jlam )
480 indxp( k ) = jlam
481*
482 110 CONTINUE
483*
484* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
485* and Q2 respectively. The eigenvalues/vectors which were not
486* deflated go into the first K slots of DLAMDA and Q2 respectively,
487* while those which were deflated go into the last N - K slots.
488*
489 IF( icompq.EQ.0 ) THEN
490 DO 120 j = 1, n
491 jp = indxp( j )
492 dlamda( j ) = d( jp )
493 perm( j ) = indxq( indx( jp ) )
494 120 CONTINUE
495 ELSE
496 DO 130 j = 1, n
497 jp = indxp( j )
498 dlamda( j ) = d( jp )
499 perm( j ) = indxq( indx( jp ) )
500 CALL scopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 )
501 130 CONTINUE
502 END IF
503*
504* The deflated eigenvalues and their corresponding vectors go back
505* into the last N - K slots of D and Q respectively.
506*
507 IF( k.LT.n ) THEN
508 IF( icompq.EQ.0 ) THEN
509 CALL scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
510 ELSE
511 CALL scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 )
512 CALL slacpy( 'A', qsiz, n-k, q2( 1, k+1 ), ldq2,
513 $ q( 1, k+1 ), ldq )
514 END IF
515 END IF
516*
517 RETURN
518*
519* End of SLAED8
520*

◆ slaed9()

subroutine slaed9 ( integer k,
integer kstart,
integer kstop,
integer n,
real, dimension( * ) d,
real, dimension( ldq, * ) q,
integer ldq,
real rho,
real, dimension( * ) dlamda,
real, dimension( * ) w,
real, dimension( lds, * ) s,
integer lds,
integer info )

SLAED9 used by SSTEDC. Finds the roots of the secular equation and updates the eigenvectors. Used when the original matrix is dense.

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

Purpose:
!>
!> SLAED9 finds the roots of the secular equation, as defined by the
!> values in D, Z, and RHO, between KSTART and KSTOP.  It makes the
!> appropriate calls to SLAED4 and then stores the new matrix of
!> eigenvectors for use in calculating the next level of Z vectors.
!>
Parameters
[in]K
!>          K is INTEGER
!>          The number of terms in the rational function to be solved by
!>          SLAED4.  K >= 0.
!>
[in]KSTART
!>          KSTART is INTEGER
!>
[in]KSTOP
!>          KSTOP is INTEGER
!>          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
!>          are to be computed.  1 <= KSTART <= KSTOP <= K.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns in the Q matrix.
!>          N >= K (delation may result in N > K).
!>
[out]D
!>          D is REAL array, dimension (N)
!>          D(I) contains the updated eigenvalues
!>          for KSTART <= I <= KSTOP.
!>
[out]Q
!>          Q is REAL array, dimension (LDQ,N)
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.  LDQ >= max( 1, N ).
!>
[in]RHO
!>          RHO is REAL
!>          The value of the parameter in the rank one update equation.
!>          RHO >= 0 required.
!>
[in]DLAMDA
!>          DLAMDA 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.
!>
[in]W
!>          W is REAL array, dimension (K)
!>          The first K elements of this array contain the components
!>          of the deflation-adjusted updating vector.
!>
[out]S
!>          S is REAL array, dimension (LDS, K)
!>          Will contain the eigenvectors of the repaired matrix which
!>          will be stored for subsequent Z vector calculation and
!>          multiplied by the previously accumulated eigenvectors
!>          to update the system.
!>
[in]LDS
!>          LDS is INTEGER
!>          The leading dimension of S.  LDS >= max( 1, 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, an eigenvalue did not converge
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 154 of file slaed9.f.

156*
157* -- LAPACK computational routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
163 REAL RHO
164* ..
165* .. Array Arguments ..
166 REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
167 $ W( * )
168* ..
169*
170* =====================================================================
171*
172* .. Local Scalars ..
173 INTEGER I, J
174 REAL TEMP
175* ..
176* .. External Functions ..
177 REAL SLAMC3, SNRM2
178 EXTERNAL slamc3, snrm2
179* ..
180* .. External Subroutines ..
181 EXTERNAL scopy, slaed4, xerbla
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC max, sign, sqrt
185* ..
186* .. Executable Statements ..
187*
188* Test the input parameters.
189*
190 info = 0
191*
192 IF( k.LT.0 ) THEN
193 info = -1
194 ELSE IF( kstart.LT.1 .OR. kstart.GT.max( 1, k ) ) THEN
195 info = -2
196 ELSE IF( max( 1, kstop ).LT.kstart .OR. kstop.GT.max( 1, k ) )
197 $ THEN
198 info = -3
199 ELSE IF( n.LT.k ) THEN
200 info = -4
201 ELSE IF( ldq.LT.max( 1, k ) ) THEN
202 info = -7
203 ELSE IF( lds.LT.max( 1, k ) ) THEN
204 info = -12
205 END IF
206 IF( info.NE.0 ) THEN
207 CALL xerbla( 'SLAED9', -info )
208 RETURN
209 END IF
210*
211* Quick return if possible
212*
213 IF( k.EQ.0 )
214 $ RETURN
215*
216* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
217* be computed with high relative accuracy (barring over/underflow).
218* This is a problem on machines without a guard digit in
219* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
220* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
221* which on any of these machines zeros out the bottommost
222* bit of DLAMDA(I) if it is 1; this makes the subsequent
223* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
224* occurs. On binary machines with a guard digit (almost all
225* machines) it does not change DLAMDA(I) at all. On hexadecimal
226* and decimal machines with a guard digit, it slightly
227* changes the bottommost bits of DLAMDA(I). It does not account
228* for hexadecimal or decimal machines without guard digits
229* (we know of none). We use a subroutine call to compute
230* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
231* this code.
232*
233 DO 10 i = 1, n
234 dlamda( i ) = slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i )
235 10 CONTINUE
236*
237 DO 20 j = kstart, kstop
238 CALL slaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info )
239*
240* If the zero finder fails, the computation is terminated.
241*
242 IF( info.NE.0 )
243 $ GO TO 120
244 20 CONTINUE
245*
246 IF( k.EQ.1 .OR. k.EQ.2 ) THEN
247 DO 40 i = 1, k
248 DO 30 j = 1, k
249 s( j, i ) = q( j, i )
250 30 CONTINUE
251 40 CONTINUE
252 GO TO 120
253 END IF
254*
255* Compute updated W.
256*
257 CALL scopy( k, w, 1, s, 1 )
258*
259* Initialize W(I) = Q(I,I)
260*
261 CALL scopy( k, q, ldq+1, w, 1 )
262 DO 70 j = 1, k
263 DO 50 i = 1, j - 1
264 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
265 50 CONTINUE
266 DO 60 i = j + 1, k
267 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) )
268 60 CONTINUE
269 70 CONTINUE
270 DO 80 i = 1, k
271 w( i ) = sign( sqrt( -w( i ) ), s( i, 1 ) )
272 80 CONTINUE
273*
274* Compute eigenvectors of the modified rank-1 modification.
275*
276 DO 110 j = 1, k
277 DO 90 i = 1, k
278 q( i, j ) = w( i ) / q( i, j )
279 90 CONTINUE
280 temp = snrm2( k, q( 1, j ), 1 )
281 DO 100 i = 1, k
282 s( i, j ) = q( i, j ) / temp
283 100 CONTINUE
284 110 CONTINUE
285*
286 120 CONTINUE
287 RETURN
288*
289* End of SLAED9
290*

◆ slaeda()

subroutine slaeda ( integer n,
integer tlvls,
integer curlvl,
integer curpbm,
integer, dimension( * ) prmptr,
integer, dimension( * ) perm,
integer, dimension( * ) givptr,
integer, dimension( 2, * ) givcol,
real, dimension( 2, * ) givnum,
real, dimension( * ) q,
integer, dimension( * ) qptr,
real, dimension( * ) z,
real, dimension( * ) ztemp,
integer info )

SLAEDA used by SSTEDC. Computes the Z vector determining the rank-one modification of the diagonal matrix. Used when the original matrix is dense.

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

Purpose:
!>
!> SLAEDA computes the Z vector corresponding to the merge step in the
!> CURLVLth step of the merge process with TLVLS steps for the CURPBMth
!> problem.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in]TLVLS
!>          TLVLS is INTEGER
!>         The total number of merging levels in the overall divide and
!>         conquer tree.
!>
[in]CURLVL
!>          CURLVL is INTEGER
!>         The current level in the overall merge routine,
!>         0 <= curlvl <= tlvls.
!>
[in]CURPBM
!>          CURPBM is INTEGER
!>         The current problem in the current level in the overall
!>         merge routine (counting from upper left to lower right).
!>
[in]PRMPTR
!>          PRMPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in PERM a
!>         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)
!>         indicates the size of the permutation and incidentally the
!>         size of the full, non-deflated problem.
!>
[in]PERM
!>          PERM is INTEGER array, dimension (N lg N)
!>         Contains the permutations (from deflation and sorting) to be
!>         applied to each eigenblock.
!>
[in]GIVPTR
!>          GIVPTR is INTEGER array, dimension (N lg N)
!>         Contains a list of pointers which indicate where in GIVCOL a
!>         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)
!>         indicates the number of Givens rotations.
!>
[in]GIVCOL
!>          GIVCOL is INTEGER array, dimension (2, N lg N)
!>         Each pair of numbers indicates a pair of columns to take place
!>         in a Givens rotation.
!>
[in]GIVNUM
!>          GIVNUM is REAL array, dimension (2, N lg N)
!>         Each number indicates the S value to be used in the
!>         corresponding Givens rotation.
!>
[in]Q
!>          Q is REAL array, dimension (N**2)
!>         Contains the square eigenblocks from previous levels, the
!>         starting positions for blocks are given by QPTR.
!>
[in]QPTR
!>          QPTR is INTEGER array, dimension (N+2)
!>         Contains a list of pointers which indicate where in Q an
!>         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates
!>         the size of the block.
!>
[out]Z
!>          Z is REAL array, dimension (N)
!>         On output this vector contains the updating vector (the last
!>         row of the first sub-eigenvector matrix and the first row of
!>         the second sub-eigenvector matrix).
!>
[out]ZTEMP
!>          ZTEMP is REAL array, dimension (N)
!>
[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:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA

Definition at line 164 of file slaeda.f.

166*
167* -- LAPACK computational routine --
168* -- LAPACK is a software package provided by Univ. of Tennessee, --
169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170*
171* .. Scalar Arguments ..
172 INTEGER CURLVL, CURPBM, INFO, N, TLVLS
173* ..
174* .. Array Arguments ..
175 INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
176 $ PRMPTR( * ), QPTR( * )
177 REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO, HALF, ONE
184 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0 )
185* ..
186* .. Local Scalars ..
187 INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
188 $ PTR, ZPTR1
189* ..
190* .. External Subroutines ..
191 EXTERNAL scopy, sgemv, srot, xerbla
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC int, real, sqrt
195* ..
196* .. Executable Statements ..
197*
198* Test the input parameters.
199*
200 info = 0
201*
202 IF( n.LT.0 ) THEN
203 info = -1
204 END IF
205 IF( info.NE.0 ) THEN
206 CALL xerbla( 'SLAEDA', -info )
207 RETURN
208 END IF
209*
210* Quick return if possible
211*
212 IF( n.EQ.0 )
213 $ RETURN
214*
215* Determine location of first number in second half.
216*
217 mid = n / 2 + 1
218*
219* Gather last/first rows of appropriate eigenblocks into center of Z
220*
221 ptr = 1
222*
223* Determine location of lowest level subproblem in the full storage
224* scheme
225*
226 curr = ptr + curpbm*2**curlvl + 2**( curlvl-1 ) - 1
227*
228* Determine size of these matrices. We add HALF to the value of
229* the SQRT in case the machine underestimates one of these square
230* roots.
231*
232 bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ) ) ) )
233 bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ) ) ) )
234 DO 10 k = 1, mid - bsiz1 - 1
235 z( k ) = zero
236 10 CONTINUE
237 CALL scopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,
238 $ z( mid-bsiz1 ), 1 )
239 CALL scopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 )
240 DO 20 k = mid + bsiz2, n
241 z( k ) = zero
242 20 CONTINUE
243*
244* Loop through remaining levels 1 -> CURLVL applying the Givens
245* rotations and permutation and then multiplying the center matrices
246* against the current Z.
247*
248 ptr = 2**tlvls + 1
249 DO 70 k = 1, curlvl - 1
250 curr = ptr + curpbm*2**( curlvl-k ) + 2**( curlvl-k-1 ) - 1
251 psiz1 = prmptr( curr+1 ) - prmptr( curr )
252 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
253 zptr1 = mid - psiz1
254*
255* Apply Givens at CURR and CURR+1
256*
257 DO 30 i = givptr( curr ), givptr( curr+1 ) - 1
258 CALL srot( 1, z( zptr1+givcol( 1, i )-1 ), 1,
259 $ z( zptr1+givcol( 2, i )-1 ), 1, givnum( 1, i ),
260 $ givnum( 2, i ) )
261 30 CONTINUE
262 DO 40 i = givptr( curr+1 ), givptr( curr+2 ) - 1
263 CALL srot( 1, z( mid-1+givcol( 1, i ) ), 1,
264 $ z( mid-1+givcol( 2, i ) ), 1, givnum( 1, i ),
265 $ givnum( 2, i ) )
266 40 CONTINUE
267 psiz1 = prmptr( curr+1 ) - prmptr( curr )
268 psiz2 = prmptr( curr+2 ) - prmptr( curr+1 )
269 DO 50 i = 0, psiz1 - 1
270 ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1 )
271 50 CONTINUE
272 DO 60 i = 0, psiz2 - 1
273 ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1 )
274 60 CONTINUE
275*
276* Multiply Blocks at CURR and CURR+1
277*
278* Determine size of these matrices. We add HALF to the value of
279* the SQRT in case the machine underestimates one of these
280* square roots.
281*
282 bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ) ) ) )
283 bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+
284 $ 1 ) ) ) )
285 IF( bsiz1.GT.0 ) THEN
286 CALL sgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),
287 $ bsiz1, ztemp( 1 ), 1, zero, z( zptr1 ), 1 )
288 END IF
289 CALL scopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),
290 $ 1 )
291 IF( bsiz2.GT.0 ) THEN
292 CALL sgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),
293 $ bsiz2, ztemp( psiz1+1 ), 1, zero, z( mid ), 1 )
294 END IF
295 CALL scopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,
296 $ z( mid+bsiz2 ), 1 )
297*
298 ptr = ptr + 2**( tlvls-k )
299 70 CONTINUE
300*
301 RETURN
302*
303* End of SLAEDA
304*
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156

◆ slagtf()

subroutine slagtf ( integer n,
real, dimension( * ) a,
real lambda,
real, dimension( * ) b,
real, dimension( * ) c,
real tol,
real, dimension( * ) d,
integer, dimension( * ) in,
integer info )

SLAGTF computes an LU factorization of a matrix T-λI, where T is a general tridiagonal matrix, and λ a scalar, using partial pivoting with row interchanges.

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

Purpose:
!>
!> SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
!> tridiagonal matrix and lambda is a scalar, as
!>
!>    T - lambda*I = PLU,
!>
!> where P is a permutation matrix, L is a unit lower tridiagonal matrix
!> with at most one non-zero sub-diagonal elements per column and U is
!> an upper triangular matrix with at most two non-zero super-diagonal
!> elements per column.
!>
!> The factorization is obtained by Gaussian elimination with partial
!> pivoting and implicit row scaling.
!>
!> The parameter LAMBDA is included in the routine so that SLAGTF may
!> be used, in conjunction with SLAGTS, to obtain eigenvectors of T by
!> inverse iteration.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix T.
!>
[in,out]A
!>          A is REAL array, dimension (N)
!>          On entry, A must contain the diagonal elements of T.
!>
!>          On exit, A is overwritten by the n diagonal elements of the
!>          upper triangular matrix U of the factorization of T.
!>
[in]LAMBDA
!>          LAMBDA is REAL
!>          On entry, the scalar lambda.
!>
[in,out]B
!>          B is REAL array, dimension (N-1)
!>          On entry, B must contain the (n-1) super-diagonal elements of
!>          T.
!>
!>          On exit, B is overwritten by the (n-1) super-diagonal
!>          elements of the matrix U of the factorization of T.
!>
[in,out]C
!>          C is REAL array, dimension (N-1)
!>          On entry, C must contain the (n-1) sub-diagonal elements of
!>          T.
!>
!>          On exit, C is overwritten by the (n-1) sub-diagonal elements
!>          of the matrix L of the factorization of T.
!>
[in]TOL
!>          TOL is REAL
!>          On entry, a relative tolerance used to indicate whether or
!>          not the matrix (T - lambda*I) is nearly singular. TOL should
!>          normally be chose as approximately the largest relative error
!>          in the elements of T. For example, if the elements of T are
!>          correct to about 4 significant figures, then TOL should be
!>          set to about 5*10**(-4). If TOL is supplied as less than eps,
!>          where eps is the relative machine precision, then the value
!>          eps is used in place of TOL.
!>
[out]D
!>          D is REAL array, dimension (N-2)
!>          On exit, D is overwritten by the (n-2) second super-diagonal
!>          elements of the matrix U of the factorization of T.
!>
[out]IN
!>          IN is INTEGER array, dimension (N)
!>          On exit, IN contains details of the permutation matrix P. If
!>          an interchange occurred at the kth step of the elimination,
!>          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
!>          returns the smallest positive integer j such that
!>
!>             abs( u(j,j) ) <= norm( (T - lambda*I)(j) )*TOL,
!>
!>          where norm( A(j) ) denotes the sum of the absolute values of
!>          the jth row of the matrix A. If no such j exists then IN(n)
!>          is returned as zero. If IN(n) is returned as positive, then a
!>          diagonal element of U is small, indicating that
!>          (T - lambda*I) is singular or nearly singular,
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the kth argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file slagtf.f.

156*
157* -- LAPACK computational routine --
158* -- LAPACK is a software package provided by Univ. of Tennessee, --
159* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161* .. Scalar Arguments ..
162 INTEGER INFO, N
163 REAL LAMBDA, TOL
164* ..
165* .. Array Arguments ..
166 INTEGER IN( * )
167 REAL A( * ), B( * ), C( * ), D( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 REAL ZERO
174 parameter( zero = 0.0e+0 )
175* ..
176* .. Local Scalars ..
177 INTEGER K
178 REAL EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, max
182* ..
183* .. External Functions ..
184 REAL SLAMCH
185 EXTERNAL slamch
186* ..
187* .. External Subroutines ..
188 EXTERNAL xerbla
189* ..
190* .. Executable Statements ..
191*
192 info = 0
193 IF( n.LT.0 ) THEN
194 info = -1
195 CALL xerbla( 'SLAGTF', -info )
196 RETURN
197 END IF
198*
199 IF( n.EQ.0 )
200 $ RETURN
201*
202 a( 1 ) = a( 1 ) - lambda
203 in( n ) = 0
204 IF( n.EQ.1 ) THEN
205 IF( a( 1 ).EQ.zero )
206 $ in( 1 ) = 1
207 RETURN
208 END IF
209*
210 eps = slamch( 'Epsilon' )
211*
212 tl = max( tol, eps )
213 scale1 = abs( a( 1 ) ) + abs( b( 1 ) )
214 DO 10 k = 1, n - 1
215 a( k+1 ) = a( k+1 ) - lambda
216 scale2 = abs( c( k ) ) + abs( a( k+1 ) )
217 IF( k.LT.( n-1 ) )
218 $ scale2 = scale2 + abs( b( k+1 ) )
219 IF( a( k ).EQ.zero ) THEN
220 piv1 = zero
221 ELSE
222 piv1 = abs( a( k ) ) / scale1
223 END IF
224 IF( c( k ).EQ.zero ) THEN
225 in( k ) = 0
226 piv2 = zero
227 scale1 = scale2
228 IF( k.LT.( n-1 ) )
229 $ d( k ) = zero
230 ELSE
231 piv2 = abs( c( k ) ) / scale2
232 IF( piv2.LE.piv1 ) THEN
233 in( k ) = 0
234 scale1 = scale2
235 c( k ) = c( k ) / a( k )
236 a( k+1 ) = a( k+1 ) - c( k )*b( k )
237 IF( k.LT.( n-1 ) )
238 $ d( k ) = zero
239 ELSE
240 in( k ) = 1
241 mult = a( k ) / c( k )
242 a( k ) = c( k )
243 temp = a( k+1 )
244 a( k+1 ) = b( k ) - mult*temp
245 IF( k.LT.( n-1 ) ) THEN
246 d( k ) = b( k+1 )
247 b( k+1 ) = -mult*d( k )
248 END IF
249 b( k ) = temp
250 c( k ) = mult
251 END IF
252 END IF
253 IF( ( max( piv1, piv2 ).LE.tl ) .AND. ( in( n ).EQ.0 ) )
254 $ in( n ) = k
255 10 CONTINUE
256 IF( ( abs( a( n ) ).LE.scale1*tl ) .AND. ( in( n ).EQ.0 ) )
257 $ in( n ) = n
258*
259 RETURN
260*
261* End of SLAGTF
262*

◆ slamrg()

subroutine slamrg ( integer n1,
integer n2,
real, dimension( * ) a,
integer strd1,
integer strd2,
integer, dimension( * ) index )

SLAMRG creates a permutation list to merge the entries of two independently sorted sets into a single set sorted in ascending order.

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

Purpose:
!>
!> SLAMRG will create a permutation list which will merge the elements
!> of A (which is composed of two independently sorted sets) into a
!> single set which is sorted in ascending order.
!>
Parameters
[in]N1
!>          N1 is INTEGER
!>
[in]N2
!>          N2 is INTEGER
!>         These arguments contain the respective lengths of the two
!>         sorted lists to be merged.
!>
[in]A
!>          A is REAL array, dimension (N1+N2)
!>         The first N1 elements of A contain a list of numbers which
!>         are sorted in either ascending or descending order.  Likewise
!>         for the final N2 elements.
!>
[in]STRD1
!>          STRD1 is INTEGER
!>
[in]STRD2
!>          STRD2 is INTEGER
!>         These are the strides to be taken through the array A.
!>         Allowable strides are 1 and -1.  They indicate whether a
!>         subset of A is sorted in ascending (STRDx = 1) or descending
!>         (STRDx = -1) order.
!>
[out]INDEX
!>          INDEX is INTEGER array, dimension (N1+N2)
!>         On exit this array will contain a permutation such that
!>         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
!>         sorted in ascending order.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 98 of file slamrg.f.

99*
100* -- LAPACK computational routine --
101* -- LAPACK is a software package provided by Univ. of Tennessee, --
102* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*
104* .. Scalar Arguments ..
105 INTEGER N1, N2, STRD1, STRD2
106* ..
107* .. Array Arguments ..
108 INTEGER INDEX( * )
109 REAL A( * )
110* ..
111*
112* =====================================================================
113*
114* .. Local Scalars ..
115 INTEGER I, IND1, IND2, N1SV, N2SV
116* ..
117* .. Executable Statements ..
118*
119 n1sv = n1
120 n2sv = n2
121 IF( strd1.GT.0 ) THEN
122 ind1 = 1
123 ELSE
124 ind1 = n1
125 END IF
126 IF( strd2.GT.0 ) THEN
127 ind2 = 1 + n1
128 ELSE
129 ind2 = n1 + n2
130 END IF
131 i = 1
132* while ( (N1SV > 0) & (N2SV > 0) )
133 10 CONTINUE
134 IF( n1sv.GT.0 .AND. n2sv.GT.0 ) THEN
135 IF( a( ind1 ).LE.a( ind2 ) ) THEN
136 index( i ) = ind1
137 i = i + 1
138 ind1 = ind1 + strd1
139 n1sv = n1sv - 1
140 ELSE
141 index( i ) = ind2
142 i = i + 1
143 ind2 = ind2 + strd2
144 n2sv = n2sv - 1
145 END IF
146 GO TO 10
147 END IF
148* end while
149 IF( n1sv.EQ.0 ) THEN
150 DO 20 n1sv = 1, n2sv
151 index( i ) = ind2
152 i = i + 1
153 ind2 = ind2 + strd2
154 20 CONTINUE
155 ELSE
156* N2SV .EQ. 0
157 DO 30 n2sv = 1, n1sv
158 index( i ) = ind1
159 i = i + 1
160 ind1 = ind1 + strd1
161 30 CONTINUE
162 END IF
163*
164 RETURN
165*
166* End of SLAMRG
167*

◆ slartgs()

subroutine slartgs ( real x,
real y,
real sigma,
real cs,
real sn )

SLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.

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

Purpose:
!>
!> SLARTGS generates a plane rotation designed to introduce a bulge in
!> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
!> problem. X and Y are the top-row entries, and SIGMA is the shift.
!> The computed CS and SN define a plane rotation satisfying
!>
!>    [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],
!>    [ -SN  CS  ]     [    X * Y    ]     [ 0 ]
!>
!> with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the
!> rotation is by PI/2.
!>
Parameters
[in]X
!>          X is REAL
!>          The (1,1) entry of an upper bidiagonal matrix.
!>
[in]Y
!>          Y is REAL
!>          The (1,2) entry of an upper bidiagonal matrix.
!>
[in]SIGMA
!>          SIGMA is REAL
!>          The shift.
!>
[out]CS
!>          CS is REAL
!>          The cosine of the rotation.
!>
[out]SN
!>          SN is REAL
!>          The sine of the rotation.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 89 of file slartgs.f.

90*
91* -- LAPACK computational routine --
92* -- LAPACK is a software package provided by Univ. of Tennessee, --
93* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94*
95* .. Scalar Arguments ..
96 REAL CS, SIGMA, SN, X, Y
97* ..
98*
99* ===================================================================
100*
101* .. Parameters ..
102 REAL NEGONE, ONE, ZERO
103 parameter( negone = -1.0e0, one = 1.0e0, zero = 0.0e0 )
104* ..
105* .. Local Scalars ..
106 REAL R, S, THRESH, W, Z
107* ..
108* .. External Subroutines ..
109 EXTERNAL slartgp
110* ..
111* .. External Functions ..
112 REAL SLAMCH
113 EXTERNAL slamch
114* .. Executable Statements ..
115*
116 thresh = slamch('E')
117*
118* Compute the first column of B**T*B - SIGMA^2*I, up to a scale
119* factor.
120*
121 IF( (sigma .EQ. zero .AND. abs(x) .LT. thresh) .OR.
122 $ (abs(x) .EQ. sigma .AND. y .EQ. zero) ) THEN
123 z = zero
124 w = zero
125 ELSE IF( sigma .EQ. zero ) THEN
126 IF( x .GE. zero ) THEN
127 z = x
128 w = y
129 ELSE
130 z = -x
131 w = -y
132 END IF
133 ELSE IF( abs(x) .LT. thresh ) THEN
134 z = -sigma*sigma
135 w = zero
136 ELSE
137 IF( x .GE. zero ) THEN
138 s = one
139 ELSE
140 s = negone
141 END IF
142 z = s * (abs(x)-sigma) * (s+sigma/x)
143 w = s * y
144 END IF
145*
146* Generate the rotation.
147* CALL SLARTGP( Z, W, CS, SN, R ) might seem more natural;
148* reordering the arguments ensures that if Z = 0 then the rotation
149* is by PI/2.
150*
151 CALL slartgp( w, z, sn, cs, r )
152*
153 RETURN
154*
155* End SLARTGS
156*
slartgp
subroutine slartgp(f, g, cs, sn, r)
SLARTGP generates a plane rotation so that the diagonal is nonnegative.
Definition slartgp.f:95

◆ slasq1()

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

SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr.

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

Purpose:
!>
!> SLASQ1 computes the singular values of a real N-by-N bidiagonal
!> matrix with diagonal D and off-diagonal E. The singular values
!> are computed to high relative accuracy, in the absence of
!> denormalization, underflow and overflow. The algorithm was first
!> presented in
!>
!>  by K. V.
!> Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
!> 1994,
!>
!> and the present implementation is described in , LAPACK Working Note.
!>
Parameters
[in]N
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>        On entry, D contains the diagonal elements of the
!>        bidiagonal matrix whose SVD is desired. On normal exit,
!>        D contains the singular values in decreasing order.
!>
[in,out]E
!>          E is REAL array, dimension (N)
!>        On entry, elements E(1:N-1) contain the off-diagonal elements
!>        of the bidiagonal matrix whose SVD is desired.
!>        On exit, E is overwritten.
!>
[out]WORK
!>          WORK is REAL array, dimension (4*N)
!>
[out]INFO
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if INFO = -i, the i-th argument had an illegal value
!>        > 0: the algorithm failed
!>             = 1, a split was marked by a positive value in E
!>             = 2, current block of Z not diagonalized after 100*N
!>                  iterations (in inner while loop)  On exit D and E
!>                  represent a matrix with the same singular values
!>                  which the calling subroutine could use to finish the
!>                  computation, or even feed back into SLASQ1
!>             = 3, termination criterion of outer while loop not met
!>                  (program created more than N unreduced blocks)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file slasq1.f.

108*
109* -- LAPACK computational routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER INFO, N
115* ..
116* .. Array Arguments ..
117 REAL D( * ), E( * ), WORK( * )
118* ..
119*
120* =====================================================================
121*
122* .. Parameters ..
123 REAL ZERO
124 parameter( zero = 0.0e0 )
125* ..
126* .. Local Scalars ..
127 INTEGER I, IINFO
128 REAL EPS, SCALE, SAFMIN, SIGMN, SIGMX
129* ..
130* .. External Subroutines ..
131 EXTERNAL scopy, slas2, slascl, slasq2, slasrt, xerbla
132* ..
133* .. External Functions ..
134 REAL SLAMCH
135 EXTERNAL slamch
136* ..
137* .. Intrinsic Functions ..
138 INTRINSIC abs, max, sqrt
139* ..
140* .. Executable Statements ..
141*
142 info = 0
143 IF( n.LT.0 ) THEN
144 info = -1
145 CALL xerbla( 'SLASQ1', -info )
146 RETURN
147 ELSE IF( n.EQ.0 ) THEN
148 RETURN
149 ELSE IF( n.EQ.1 ) THEN
150 d( 1 ) = abs( d( 1 ) )
151 RETURN
152 ELSE IF( n.EQ.2 ) THEN
153 CALL slas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx )
154 d( 1 ) = sigmx
155 d( 2 ) = sigmn
156 RETURN
157 END IF
158*
159* Estimate the largest singular value.
160*
161 sigmx = zero
162 DO 10 i = 1, n - 1
163 d( i ) = abs( d( i ) )
164 sigmx = max( sigmx, abs( e( i ) ) )
165 10 CONTINUE
166 d( n ) = abs( d( n ) )
167*
168* Early return if SIGMX is zero (matrix is already diagonal).
169*
170 IF( sigmx.EQ.zero ) THEN
171 CALL slasrt( 'D', n, d, iinfo )
172 RETURN
173 END IF
174*
175 DO 20 i = 1, n
176 sigmx = max( sigmx, d( i ) )
177 20 CONTINUE
178*
179* Copy D and E into WORK (in the Z format) and scale (squaring the
180* input data makes scaling by a power of the radix pointless).
181*
182 eps = slamch( 'Precision' )
183 safmin = slamch( 'Safe minimum' )
184 scale = sqrt( eps / safmin )
185 CALL scopy( n, d, 1, work( 1 ), 2 )
186 CALL scopy( n-1, e, 1, work( 2 ), 2 )
187 CALL slascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,
188 $ iinfo )
189*
190* Compute the q's and e's.
191*
192 DO 30 i = 1, 2*n - 1
193 work( i ) = work( i )**2
194 30 CONTINUE
195 work( 2*n ) = zero
196*
197 CALL slasq2( n, work, info )
198*
199 IF( info.EQ.0 ) THEN
200 DO 40 i = 1, n
201 d( i ) = sqrt( work( i ) )
202 40 CONTINUE
203 CALL slascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo )
204 ELSE IF( info.EQ.2 ) THEN
205*
206* Maximum number of iterations exceeded. Move data from WORK
207* into D and E so the calling subroutine can try to finish
208*
209 DO i = 1, n
210 d( i ) = sqrt( work( 2*i-1 ) )
211 e( i ) = sqrt( work( 2*i ) )
212 END DO
213 CALL slascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo )
214 CALL slascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo )
215 END IF
216*
217 RETURN
218*
219* End of SLASQ1
220*
slasrt
subroutine slasrt(id, n, d, info)
SLASRT sorts numbers in increasing or decreasing order.
Definition slasrt.f:88
slasq2
subroutine slasq2(n, z, info)
SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated ...
Definition slasq2.f:112

◆ slasq2()

subroutine slasq2 ( integer n,
real, dimension( * ) z,
integer info )

SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix associated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> SLASQ2 computes all the eigenvalues of the symmetric positive
!> definite tridiagonal matrix associated with the qd array Z to high
!> relative accuracy are computed to high relative accuracy, in the
!> absence of denormalization, underflow and overflow.
!>
!> To see the relation of Z to the tridiagonal matrix, let L be a
!> unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
!> let U be an upper bidiagonal matrix with 1's above and diagonal
!> Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
!> symmetric tridiagonal to which it is similar.
!>
!> Note : SLASQ2 defines a logical variable, IEEE, which is true
!> on machines which follow ieee-754 floating-point standard in their
!> handling of infinities and NaNs, and false otherwise. This variable
!> is passed to SLASQ3.
!>
Parameters
[in]N
!>          N is INTEGER
!>        The number of rows and columns in the matrix. N >= 0.
!>
[in,out]Z
!>          Z is REAL array, dimension ( 4*N )
!>        On entry Z holds the qd array. On exit, entries 1 to N hold
!>        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
!>        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
!>        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
!>        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
!>        shifts that failed.
!>
[out]INFO
!>          INFO is INTEGER
!>        = 0: successful exit
!>        < 0: if the i-th argument is a scalar and had an illegal
!>             value, then INFO = -i, if the i-th argument is an
!>             array and the j-entry had an illegal value, then
!>             INFO = -(i*100+j)
!>        > 0: the algorithm failed
!>              = 1, a split was marked by a positive value in E
!>              = 2, current block of Z not diagonalized after 100*N
!>                   iterations (in inner while loop).  On exit Z holds
!>                   a qd array with the same eigenvalues as the given Z.
!>              = 3, termination criterion of outer while loop not met
!>                   (program created more than N unreduced blocks)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Local Variables: I0:N0 defines a current unreduced segment of Z.
!>  The shifts are accumulated in SIGMA. Iteration count is in ITER.
!>  Ping-pong is controlled by PP (alternates between 0 and 1).
!>

Definition at line 111 of file slasq2.f.

112*
113* -- LAPACK computational routine --
114* -- LAPACK is a software package provided by Univ. of Tennessee, --
115* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
116*
117* .. Scalar Arguments ..
118 INTEGER INFO, N
119* ..
120* .. Array Arguments ..
121 REAL Z( * )
122* ..
123*
124* =====================================================================
125*
126* .. Parameters ..
127 REAL CBIAS
128 parameter( cbias = 1.50e0 )
129 REAL ZERO, HALF, ONE, TWO, FOUR, HUNDRD
130 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0,
131 $ two = 2.0e0, four = 4.0e0, hundrd = 100.0e0 )
132* ..
133* .. Local Scalars ..
134 LOGICAL IEEE
135 INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
136 $ KMIN, N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE,
137 $ I1, N1
138 REAL D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN,
139 $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX,
140 $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL,
141 $ TOL2, TRACE, ZMAX, TEMPE, TEMPQ
142* ..
143* .. External Subroutines ..
144 EXTERNAL slasq3, slasrt, xerbla
145* ..
146* .. External Functions ..
147 REAL SLAMCH
148 EXTERNAL slamch
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC abs, max, min, real, sqrt
152* ..
153* .. Executable Statements ..
154*
155* Test the input arguments.
156* (in case SLASQ2 is not called by SLASQ1)
157*
158 info = 0
159 eps = slamch( 'Precision' )
160 safmin = slamch( 'Safe minimum' )
161 tol = eps*hundrd
162 tol2 = tol**2
163*
164 IF( n.LT.0 ) THEN
165 info = -1
166 CALL xerbla( 'SLASQ2', 1 )
167 RETURN
168 ELSE IF( n.EQ.0 ) THEN
169 RETURN
170 ELSE IF( n.EQ.1 ) THEN
171*
172* 1-by-1 case.
173*
174 IF( z( 1 ).LT.zero ) THEN
175 info = -201
176 CALL xerbla( 'SLASQ2', 2 )
177 END IF
178 RETURN
179 ELSE IF( n.EQ.2 ) THEN
180*
181* 2-by-2 case.
182*
183 IF( z( 1 ).LT.zero ) THEN
184 info = -201
185 CALL xerbla( 'SLASQ2', 2 )
186 RETURN
187 ELSE IF( z( 2 ).LT.zero ) THEN
188 info = -202
189 CALL xerbla( 'SLASQ2', 2 )
190 RETURN
191 ELSE IF( z( 3 ).LT.zero ) THEN
192 info = -203
193 CALL xerbla( 'SLASQ2', 2 )
194 RETURN
195 ELSE IF( z( 3 ).GT.z( 1 ) ) THEN
196 d = z( 3 )
197 z( 3 ) = z( 1 )
198 z( 1 ) = d
199 END IF
200 z( 5 ) = z( 1 ) + z( 2 ) + z( 3 )
201 IF( z( 2 ).GT.z( 3 )*tol2 ) THEN
202 t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) )
203 s = z( 3 )*( z( 2 ) / t )
204 IF( s.LE.t ) THEN
205 s = z( 3 )*( z( 2 ) / ( t*( one+sqrt( one+s / t ) ) ) )
206 ELSE
207 s = z( 3 )*( z( 2 ) / ( t+sqrt( t )*sqrt( t+s ) ) )
208 END IF
209 t = z( 1 ) + ( s+z( 2 ) )
210 z( 3 ) = z( 3 )*( z( 1 ) / t )
211 z( 1 ) = t
212 END IF
213 z( 2 ) = z( 3 )
214 z( 6 ) = z( 2 ) + z( 1 )
215 RETURN
216 END IF
217*
218* Check for negative data and compute sums of q's and e's.
219*
220 z( 2*n ) = zero
221 emin = z( 2 )
222 qmax = zero
223 zmax = zero
224 d = zero
225 e = zero
226*
227 DO 10 k = 1, 2*( n-1 ), 2
228 IF( z( k ).LT.zero ) THEN
229 info = -( 200+k )
230 CALL xerbla( 'SLASQ2', 2 )
231 RETURN
232 ELSE IF( z( k+1 ).LT.zero ) THEN
233 info = -( 200+k+1 )
234 CALL xerbla( 'SLASQ2', 2 )
235 RETURN
236 END IF
237 d = d + z( k )
238 e = e + z( k+1 )
239 qmax = max( qmax, z( k ) )
240 emin = min( emin, z( k+1 ) )
241 zmax = max( qmax, zmax, z( k+1 ) )
242 10 CONTINUE
243 IF( z( 2*n-1 ).LT.zero ) THEN
244 info = -( 200+2*n-1 )
245 CALL xerbla( 'SLASQ2', 2 )
246 RETURN
247 END IF
248 d = d + z( 2*n-1 )
249 qmax = max( qmax, z( 2*n-1 ) )
250 zmax = max( qmax, zmax )
251*
252* Check for diagonality.
253*
254 IF( e.EQ.zero ) THEN
255 DO 20 k = 2, n
256 z( k ) = z( 2*k-1 )
257 20 CONTINUE
258 CALL slasrt( 'D', n, z, iinfo )
259 z( 2*n-1 ) = d
260 RETURN
261 END IF
262*
263 trace = d + e
264*
265* Check for zero data.
266*
267 IF( trace.EQ.zero ) THEN
268 z( 2*n-1 ) = zero
269 RETURN
270 END IF
271*
272* Check whether the machine is IEEE conformable.
273*
274* IEEE = ( ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 )
275*
276* [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with
277* some the test matrices of type 16. The double precision code is fine.
278*
279 ieee = .false.
280*
281* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
282*
283 DO 30 k = 2*n, 2, -2
284 z( 2*k ) = zero
285 z( 2*k-1 ) = z( k )
286 z( 2*k-2 ) = zero
287 z( 2*k-3 ) = z( k-1 )
288 30 CONTINUE
289*
290 i0 = 1
291 n0 = n
292*
293* Reverse the qd-array, if warranted.
294*
295 IF( cbias*z( 4*i0-3 ).LT.z( 4*n0-3 ) ) THEN
296 ipn4 = 4*( i0+n0 )
297 DO 40 i4 = 4*i0, 2*( i0+n0-1 ), 4
298 temp = z( i4-3 )
299 z( i4-3 ) = z( ipn4-i4-3 )
300 z( ipn4-i4-3 ) = temp
301 temp = z( i4-1 )
302 z( i4-1 ) = z( ipn4-i4-5 )
303 z( ipn4-i4-5 ) = temp
304 40 CONTINUE
305 END IF
306*
307* Initial split checking via dqd and Li's test.
308*
309 pp = 0
310*
311 DO 80 k = 1, 2
312*
313 d = z( 4*n0+pp-3 )
314 DO 50 i4 = 4*( n0-1 ) + pp, 4*i0 + pp, -4
315 IF( z( i4-1 ).LE.tol2*d ) THEN
316 z( i4-1 ) = -zero
317 d = z( i4-3 )
318 ELSE
319 d = z( i4-3 )*( d / ( d+z( i4-1 ) ) )
320 END IF
321 50 CONTINUE
322*
323* dqd maps Z to ZZ plus Li's test.
324*
325 emin = z( 4*i0+pp+1 )
326 d = z( 4*i0+pp-3 )
327 DO 60 i4 = 4*i0 + pp, 4*( n0-1 ) + pp, 4
328 z( i4-2*pp-2 ) = d + z( i4-1 )
329 IF( z( i4-1 ).LE.tol2*d ) THEN
330 z( i4-1 ) = -zero
331 z( i4-2*pp-2 ) = d
332 z( i4-2*pp ) = zero
333 d = z( i4+1 )
334 ELSE IF( safmin*z( i4+1 ).LT.z( i4-2*pp-2 ) .AND.
335 $ safmin*z( i4-2*pp-2 ).LT.z( i4+1 ) ) THEN
336 temp = z( i4+1 ) / z( i4-2*pp-2 )
337 z( i4-2*pp ) = z( i4-1 )*temp
338 d = d*temp
339 ELSE
340 z( i4-2*pp ) = z( i4+1 )*( z( i4-1 ) / z( i4-2*pp-2 ) )
341 d = z( i4+1 )*( d / z( i4-2*pp-2 ) )
342 END IF
343 emin = min( emin, z( i4-2*pp ) )
344 60 CONTINUE
345 z( 4*n0-pp-2 ) = d
346*
347* Now find qmax.
348*
349 qmax = z( 4*i0-pp-2 )
350 DO 70 i4 = 4*i0 - pp + 2, 4*n0 - pp - 2, 4
351 qmax = max( qmax, z( i4 ) )
352 70 CONTINUE
353*
354* Prepare for the next iteration on K.
355*
356 pp = 1 - pp
357 80 CONTINUE
358*
359* Initialise variables to pass to SLASQ3.
360*
361 ttype = 0
362 dmin1 = zero
363 dmin2 = zero
364 dn = zero
365 dn1 = zero
366 dn2 = zero
367 g = zero
368 tau = zero
369*
370 iter = 2
371 nfail = 0
372 ndiv = 2*( n0-i0 )
373*
374 DO 160 iwhila = 1, n + 1
375 IF( n0.LT.1 )
376 $ GO TO 170
377*
378* While array unfinished do
379*
380* E(N0) holds the value of SIGMA when submatrix in I0:N0
381* splits from the rest of the array, but is negated.
382*
383 desig = zero
384 IF( n0.EQ.n ) THEN
385 sigma = zero
386 ELSE
387 sigma = -z( 4*n0-1 )
388 END IF
389 IF( sigma.LT.zero ) THEN
390 info = 1
391 RETURN
392 END IF
393*
394* Find last unreduced submatrix's top index I0, find QMAX and
395* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
396*
397 emax = zero
398 IF( n0.GT.i0 ) THEN
399 emin = abs( z( 4*n0-5 ) )
400 ELSE
401 emin = zero
402 END IF
403 qmin = z( 4*n0-3 )
404 qmax = qmin
405 DO 90 i4 = 4*n0, 8, -4
406 IF( z( i4-5 ).LE.zero )
407 $ GO TO 100
408 IF( qmin.GE.four*emax ) THEN
409 qmin = min( qmin, z( i4-3 ) )
410 emax = max( emax, z( i4-5 ) )
411 END IF
412 qmax = max( qmax, z( i4-7 )+z( i4-5 ) )
413 emin = min( emin, z( i4-5 ) )
414 90 CONTINUE
415 i4 = 4
416*
417 100 CONTINUE
418 i0 = i4 / 4
419 pp = 0
420*
421 IF( n0-i0.GT.1 ) THEN
422 dee = z( 4*i0-3 )
423 deemin = dee
424 kmin = i0
425 DO 110 i4 = 4*i0+1, 4*n0-3, 4
426 dee = z( i4 )*( dee /( dee+z( i4-2 ) ) )
427 IF( dee.LE.deemin ) THEN
428 deemin = dee
429 kmin = ( i4+3 )/4
430 END IF
431 110 CONTINUE
432 IF( (kmin-i0)*2.LT.n0-kmin .AND.
433 $ deemin.LE.half*z(4*n0-3) ) THEN
434 ipn4 = 4*( i0+n0 )
435 pp = 2
436 DO 120 i4 = 4*i0, 2*( i0+n0-1 ), 4
437 temp = z( i4-3 )
438 z( i4-3 ) = z( ipn4-i4-3 )
439 z( ipn4-i4-3 ) = temp
440 temp = z( i4-2 )
441 z( i4-2 ) = z( ipn4-i4-2 )
442 z( ipn4-i4-2 ) = temp
443 temp = z( i4-1 )
444 z( i4-1 ) = z( ipn4-i4-5 )
445 z( ipn4-i4-5 ) = temp
446 temp = z( i4 )
447 z( i4 ) = z( ipn4-i4-4 )
448 z( ipn4-i4-4 ) = temp
449 120 CONTINUE
450 END IF
451 END IF
452*
453* Put -(initial shift) into DMIN.
454*
455 dmin = -max( zero, qmin-two*sqrt( qmin )*sqrt( emax ) )
456*
457* Now I0:N0 is unreduced.
458* PP = 0 for ping, PP = 1 for pong.
459* PP = 2 indicates that flipping was applied to the Z array and
460* and that the tests for deflation upon entry in SLASQ3
461* should not be performed.
462*
463 nbig = 100*( n0-i0+1 )
464 DO 140 iwhilb = 1, nbig
465 IF( i0.GT.n0 )
466 $ GO TO 150
467*
468* While submatrix unfinished take a good dqds step.
469*
470 CALL slasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,
471 $ iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1,
472 $ dn2, g, tau )
473*
474 pp = 1 - pp
475*
476* When EMIN is very small check for splits.
477*
478 IF( pp.EQ.0 .AND. n0-i0.GE.3 ) THEN
479 IF( z( 4*n0 ).LE.tol2*qmax .OR.
480 $ z( 4*n0-1 ).LE.tol2*sigma ) THEN
481 splt = i0 - 1
482 qmax = z( 4*i0-3 )
483 emin = z( 4*i0-1 )
484 oldemn = z( 4*i0 )
485 DO 130 i4 = 4*i0, 4*( n0-3 ), 4
486 IF( z( i4 ).LE.tol2*z( i4-3 ) .OR.
487 $ z( i4-1 ).LE.tol2*sigma ) THEN
488 z( i4-1 ) = -sigma
489 splt = i4 / 4
490 qmax = zero
491 emin = z( i4+3 )
492 oldemn = z( i4+4 )
493 ELSE
494 qmax = max( qmax, z( i4+1 ) )
495 emin = min( emin, z( i4-1 ) )
496 oldemn = min( oldemn, z( i4 ) )
497 END IF
498 130 CONTINUE
499 z( 4*n0-1 ) = emin
500 z( 4*n0 ) = oldemn
501 i0 = splt + 1
502 END IF
503 END IF
504*
505 140 CONTINUE
506*
507 info = 2
508*
509* Maximum number of iterations exceeded, restore the shift
510* SIGMA and place the new d's and e's in a qd array.
511* This might need to be done for several blocks
512*
513 i1 = i0
514 n1 = n0
515 145 CONTINUE
516 tempq = z( 4*i0-3 )
517 z( 4*i0-3 ) = z( 4*i0-3 ) + sigma
518 DO k = i0+1, n0
519 tempe = z( 4*k-5 )
520 z( 4*k-5 ) = z( 4*k-5 ) * (tempq / z( 4*k-7 ))
521 tempq = z( 4*k-3 )
522 z( 4*k-3 ) = z( 4*k-3 ) + sigma + tempe - z( 4*k-5 )
523 END DO
524*
525* Prepare to do this on the previous block if there is one
526*
527 IF( i1.GT.1 ) THEN
528 n1 = i1-1
529 DO WHILE( ( i1.GE.2 ) .AND. ( z(4*i1-5).GE.zero ) )
530 i1 = i1 - 1
531 END DO
532 IF( i1.GE.1 ) THEN
533 sigma = -z(4*n1-1)
534 GO TO 145
535 END IF
536 END IF
537
538 DO k = 1, n
539 z( 2*k-1 ) = z( 4*k-3 )
540*
541* Only the block 1..N0 is unfinished. The rest of the e's
542* must be essentially zero, although sometimes other data
543* has been stored in them.
544*
545 IF( k.LT.n0 ) THEN
546 z( 2*k ) = z( 4*k-1 )
547 ELSE
548 z( 2*k ) = 0
549 END IF
550 END DO
551 RETURN
552*
553* end IWHILB
554*
555 150 CONTINUE
556*
557 160 CONTINUE
558*
559 info = 3
560 RETURN
561*
562* end IWHILA
563*
564 170 CONTINUE
565*
566* Move q's to the front.
567*
568 DO 180 k = 2, n
569 z( k ) = z( 4*k-3 )
570 180 CONTINUE
571*
572* Sort and compute sum of eigenvalues.
573*
574 CALL slasrt( 'D', n, z, iinfo )
575*
576 e = zero
577 DO 190 k = n, 1, -1
578 e = e + z( k )
579 190 CONTINUE
580*
581* Store trace, sum(eigenvalues) and information on performance.
582*
583 z( 2*n+1 ) = trace
584 z( 2*n+2 ) = e
585 z( 2*n+3 ) = real( iter )
586 z( 2*n+4 ) = real( ndiv ) / real( n**2 )
587 z( 2*n+5 ) = hundrd*nfail / real( iter )
588 RETURN
589*
590* End of SLASQ2
591*
slasq3
subroutine slasq3(i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, iter, ndiv, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)
SLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.
Definition slasq3.f:182

◆ slasq3()

subroutine slasq3 ( integer i0,
integer n0,
real, dimension( * ) z,
integer pp,
real dmin,
real sigma,
real desig,
real qmax,
integer nfail,
integer iter,
integer ndiv,
logical ieee,
integer ttype,
real dmin1,
real dmin2,
real dn,
real dn1,
real dn2,
real g,
real tau )

SLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr.

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

Purpose:
!>
!> SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
!> In case of failure it changes shifts, and tries again until output
!> is positive.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>         First index.
!>
[in,out]N0
!>          N0 is INTEGER
!>         Last index.
!>
[in,out]Z
!>          Z is REAL array, dimension ( 4*N0 )
!>         Z holds the qd array.
!>
[in,out]PP
!>          PP is INTEGER
!>         PP=0 for ping, PP=1 for pong.
!>         PP=2 indicates that flipping was applied to the Z array
!>         and that the initial tests for deflation should not be
!>         performed.
!>
[out]DMIN
!>          DMIN is REAL
!>         Minimum value of d.
!>
[out]SIGMA
!>          SIGMA is REAL
!>         Sum of shifts used in current segment.
!>
[in,out]DESIG
!>          DESIG is REAL
!>         Lower order part of SIGMA
!>
[in]QMAX
!>          QMAX is REAL
!>         Maximum value of q.
!>
[in,out]NFAIL
!>          NFAIL is INTEGER
!>         Increment NFAIL by 1 each time the shift was too big.
!>
[in,out]ITER
!>          ITER is INTEGER
!>         Increment ITER by 1 for each iteration.
!>
[in,out]NDIV
!>          NDIV is INTEGER
!>         Increment NDIV by 1 for each division.
!>
[in]IEEE
!>          IEEE is LOGICAL
!>         Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
!>
[in,out]TTYPE
!>          TTYPE is INTEGER
!>         Shift type.
!>
[in,out]DMIN1
!>          DMIN1 is REAL
!>
[in,out]DMIN2
!>          DMIN2 is REAL
!>
[in,out]DN
!>          DN is REAL
!>
[in,out]DN1
!>          DN1 is REAL
!>
[in,out]DN2
!>          DN2 is REAL
!>
[in,out]G
!>          G is REAL
!>
[in,out]TAU
!>          TAU is REAL
!>
!>         These are passed as arguments in order to save their values
!>         between calls to SLASQ3.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 179 of file slasq3.f.

182*
183* -- LAPACK computational routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 LOGICAL IEEE
189 INTEGER I0, ITER, N0, NDIV, NFAIL, PP
190 REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G,
191 $ QMAX, SIGMA, TAU
192* ..
193* .. Array Arguments ..
194 REAL Z( * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 REAL CBIAS
201 parameter( cbias = 1.50e0 )
202 REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
203 parameter( zero = 0.0e0, qurtr = 0.250e0, half = 0.5e0,
204 $ one = 1.0e0, two = 2.0e0, hundrd = 100.0e0 )
205* ..
206* .. Local Scalars ..
207 INTEGER IPN4, J4, N0IN, NN, TTYPE
208 REAL EPS, S, T, TEMP, TOL, TOL2
209* ..
210* .. External Subroutines ..
211 EXTERNAL slasq4, slasq5, slasq6
212* ..
213* .. External Function ..
214 REAL SLAMCH
215 LOGICAL SISNAN
216 EXTERNAL sisnan, slamch
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC abs, max, min, sqrt
220* ..
221* .. Executable Statements ..
222*
223 n0in = n0
224 eps = slamch( 'Precision' )
225 tol = eps*hundrd
226 tol2 = tol**2
227*
228* Check for deflation.
229*
230 10 CONTINUE
231*
232 IF( n0.LT.i0 )
233 $ RETURN
234 IF( n0.EQ.i0 )
235 $ GO TO 20
236 nn = 4*n0 + pp
237 IF( n0.EQ.( i0+1 ) )
238 $ GO TO 40
239*
240* Check whether E(N0-1) is negligible, 1 eigenvalue.
241*
242 IF( z( nn-5 ).GT.tol2*( sigma+z( nn-3 ) ) .AND.
243 $ z( nn-2*pp-4 ).GT.tol2*z( nn-7 ) )
244 $ GO TO 30
245*
246 20 CONTINUE
247*
248 z( 4*n0-3 ) = z( 4*n0+pp-3 ) + sigma
249 n0 = n0 - 1
250 GO TO 10
251*
252* Check whether E(N0-2) is negligible, 2 eigenvalues.
253*
254 30 CONTINUE
255*
256 IF( z( nn-9 ).GT.tol2*sigma .AND.
257 $ z( nn-2*pp-8 ).GT.tol2*z( nn-11 ) )
258 $ GO TO 50
259*
260 40 CONTINUE
261*
262 IF( z( nn-3 ).GT.z( nn-7 ) ) THEN
263 s = z( nn-3 )
264 z( nn-3 ) = z( nn-7 )
265 z( nn-7 ) = s
266 END IF
267 t = half*( ( z( nn-7 )-z( nn-3 ) )+z( nn-5 ) )
268 IF( z( nn-5 ).GT.z( nn-3 )*tol2.AND.t.NE.zero ) THEN
269 s = z( nn-3 )*( z( nn-5 ) / t )
270 IF( s.LE.t ) THEN
271 s = z( nn-3 )*( z( nn-5 ) /
272 $ ( t*( one+sqrt( one+s / t ) ) ) )
273 ELSE
274 s = z( nn-3 )*( z( nn-5 ) / ( t+sqrt( t )*sqrt( t+s ) ) )
275 END IF
276 t = z( nn-7 ) + ( s+z( nn-5 ) )
277 z( nn-3 ) = z( nn-3 )*( z( nn-7 ) / t )
278 z( nn-7 ) = t
279 END IF
280 z( 4*n0-7 ) = z( nn-7 ) + sigma
281 z( 4*n0-3 ) = z( nn-3 ) + sigma
282 n0 = n0 - 2
283 GO TO 10
284*
285 50 CONTINUE
286 IF( pp.EQ.2 )
287 $ pp = 0
288*
289* Reverse the qd-array, if warranted.
290*
291 IF( dmin.LE.zero .OR. n0.LT.n0in ) THEN
292 IF( cbias*z( 4*i0+pp-3 ).LT.z( 4*n0+pp-3 ) ) THEN
293 ipn4 = 4*( i0+n0 )
294 DO 60 j4 = 4*i0, 2*( i0+n0-1 ), 4
295 temp = z( j4-3 )
296 z( j4-3 ) = z( ipn4-j4-3 )
297 z( ipn4-j4-3 ) = temp
298 temp = z( j4-2 )
299 z( j4-2 ) = z( ipn4-j4-2 )
300 z( ipn4-j4-2 ) = temp
301 temp = z( j4-1 )
302 z( j4-1 ) = z( ipn4-j4-5 )
303 z( ipn4-j4-5 ) = temp
304 temp = z( j4 )
305 z( j4 ) = z( ipn4-j4-4 )
306 z( ipn4-j4-4 ) = temp
307 60 CONTINUE
308 IF( n0-i0.LE.4 ) THEN
309 z( 4*n0+pp-1 ) = z( 4*i0+pp-1 )
310 z( 4*n0-pp ) = z( 4*i0-pp )
311 END IF
312 dmin2 = min( dmin2, z( 4*n0+pp-1 ) )
313 z( 4*n0+pp-1 ) = min( z( 4*n0+pp-1 ), z( 4*i0+pp-1 ),
314 $ z( 4*i0+pp+3 ) )
315 z( 4*n0-pp ) = min( z( 4*n0-pp ), z( 4*i0-pp ),
316 $ z( 4*i0-pp+4 ) )
317 qmax = max( qmax, z( 4*i0+pp-3 ), z( 4*i0+pp+1 ) )
318 dmin = -zero
319 END IF
320 END IF
321*
322* Choose a shift.
323*
324 CALL slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1,
325 $ dn2, tau, ttype, g )
326*
327* Call dqds until DMIN > 0.
328*
329 70 CONTINUE
330*
331 CALL slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,
332 $ dn1, dn2, ieee, eps )
333*
334 ndiv = ndiv + ( n0-i0+2 )
335 iter = iter + 1
336*
337* Check status.
338*
339 IF( dmin.GE.zero .AND. dmin1.GE.zero ) THEN
340*
341* Success.
342*
343 GO TO 90
344*
345 ELSE IF( dmin.LT.zero .AND. dmin1.GT.zero .AND.
346 $ z( 4*( n0-1 )-pp ).LT.tol*( sigma+dn1 ) .AND.
347 $ abs( dn ).LT.tol*sigma ) THEN
348*
349* Convergence hidden by negative DN.
350*
351 z( 4*( n0-1 )-pp+2 ) = zero
352 dmin = zero
353 GO TO 90
354 ELSE IF( dmin.LT.zero ) THEN
355*
356* TAU too big. Select new TAU and try again.
357*
358 nfail = nfail + 1
359 IF( ttype.LT.-22 ) THEN
360*
361* Failed twice. Play it safe.
362*
363 tau = zero
364 ELSE IF( dmin1.GT.zero ) THEN
365*
366* Late failure. Gives excellent shift.
367*
368 tau = ( tau+dmin )*( one-two*eps )
369 ttype = ttype - 11
370 ELSE
371*
372* Early failure. Divide by 4.
373*
374 tau = qurtr*tau
375 ttype = ttype - 12
376 END IF
377 GO TO 70
378 ELSE IF( sisnan( dmin ) ) THEN
379*
380* NaN.
381*
382 IF( tau.EQ.zero ) THEN
383 GO TO 80
384 ELSE
385 tau = zero
386 GO TO 70
387 END IF
388 ELSE
389*
390* Possible underflow. Play it safe.
391*
392 GO TO 80
393 END IF
394*
395* Risk of underflow.
396*
397 80 CONTINUE
398 CALL slasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn, dn1, dn2 )
399 ndiv = ndiv + ( n0-i0+2 )
400 iter = iter + 1
401 tau = zero
402*
403 90 CONTINUE
404 IF( tau.LT.sigma ) THEN
405 desig = desig + tau
406 t = sigma + desig
407 desig = desig - ( t-sigma )
408 ELSE
409 t = sigma + tau
410 desig = sigma - ( t-tau ) + desig
411 END IF
412 sigma = t
413*
414 RETURN
415*
416* End of SLASQ3
417*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
slasq6
subroutine slasq6(i0, n0, z, pp, dmin, dmin1, dmin2, dn, dnm1, dnm2)
SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.
Definition slasq6.f:119
slasq4
subroutine slasq4(i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, tau, ttype, g)
SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous trans...
Definition slasq4.f:151
slasq5
subroutine slasq5(i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn, dnm1, dnm2, ieee, eps)
SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.
Definition slasq5.f:144

◆ slasq4()

subroutine slasq4 ( integer i0,
integer n0,
real, dimension( * ) z,
integer pp,
integer n0in,
real dmin,
real dmin1,
real dmin2,
real dn,
real dn1,
real dn2,
real tau,
integer ttype,
real g )

SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous transform. Used by sbdsqr.

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

Purpose:
!>
!> SLASQ4 computes an approximation TAU to the smallest eigenvalue
!> using values of d from the previous transform.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is REAL array, dimension ( 4*N0 )
!>        Z holds the qd array.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[in]N0IN
!>          N0IN is INTEGER
!>        The value of N0 at start of EIGTEST.
!>
[in]DMIN
!>          DMIN is REAL
!>        Minimum value of d.
!>
[in]DMIN1
!>          DMIN1 is REAL
!>        Minimum value of d, excluding D( N0 ).
!>
[in]DMIN2
!>          DMIN2 is REAL
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[in]DN
!>          DN is REAL
!>        d(N)
!>
[in]DN1
!>          DN1 is REAL
!>        d(N-1)
!>
[in]DN2
!>          DN2 is REAL
!>        d(N-2)
!>
[out]TAU
!>          TAU is REAL
!>        This is the shift.
!>
[out]TTYPE
!>          TTYPE is INTEGER
!>        Shift type.
!>
[in,out]G
!>          G is REAL
!>        G is passed as an argument in order to save its value between
!>        calls to SLASQ4.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  CNST1 = 9/16
!>

Definition at line 149 of file slasq4.f.

151*
152* -- LAPACK computational routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 INTEGER I0, N0, N0IN, PP, TTYPE
158 REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
159* ..
160* .. Array Arguments ..
161 REAL Z( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 REAL CNST1, CNST2, CNST3
168 parameter( cnst1 = 0.5630e0, cnst2 = 1.010e0,
169 $ cnst3 = 1.050e0 )
170 REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
171 parameter( qurtr = 0.250e0, third = 0.3330e0,
172 $ half = 0.50e0, zero = 0.0e0, one = 1.0e0,
173 $ two = 2.0e0, hundrd = 100.0e0 )
174* ..
175* .. Local Scalars ..
176 INTEGER I4, NN, NP
177 REAL A2, B1, B2, GAM, GAP1, GAP2, S
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC max, min, sqrt
181* ..
182* .. Executable Statements ..
183*
184* A negative DMIN forces the shift to take that absolute value
185* TTYPE records the type of shift.
186*
187 IF( dmin.LE.zero ) THEN
188 tau = -dmin
189 ttype = -1
190 RETURN
191 END IF
192*
193 nn = 4*n0 + pp
194 IF( n0in.EQ.n0 ) THEN
195*
196* No eigenvalues deflated.
197*
198 IF( dmin.EQ.dn .OR. dmin.EQ.dn1 ) THEN
199*
200 b1 = sqrt( z( nn-3 ) )*sqrt( z( nn-5 ) )
201 b2 = sqrt( z( nn-7 ) )*sqrt( z( nn-9 ) )
202 a2 = z( nn-7 ) + z( nn-5 )
203*
204* Cases 2 and 3.
205*
206 IF( dmin.EQ.dn .AND. dmin1.EQ.dn1 ) THEN
207 gap2 = dmin2 - a2 - dmin2*qurtr
208 IF( gap2.GT.zero .AND. gap2.GT.b2 ) THEN
209 gap1 = a2 - dn - ( b2 / gap2 )*b2
210 ELSE
211 gap1 = a2 - dn - ( b1+b2 )
212 END IF
213 IF( gap1.GT.zero .AND. gap1.GT.b1 ) THEN
214 s = max( dn-( b1 / gap1 )*b1, half*dmin )
215 ttype = -2
216 ELSE
217 s = zero
218 IF( dn.GT.b1 )
219 $ s = dn - b1
220 IF( a2.GT.( b1+b2 ) )
221 $ s = min( s, a2-( b1+b2 ) )
222 s = max( s, third*dmin )
223 ttype = -3
224 END IF
225 ELSE
226*
227* Case 4.
228*
229 ttype = -4
230 s = qurtr*dmin
231 IF( dmin.EQ.dn ) THEN
232 gam = dn
233 a2 = zero
234 IF( z( nn-5 ) .GT. z( nn-7 ) )
235 $ RETURN
236 b2 = z( nn-5 ) / z( nn-7 )
237 np = nn - 9
238 ELSE
239 np = nn - 2*pp
240 gam = dn1
241 IF( z( np-4 ) .GT. z( np-2 ) )
242 $ RETURN
243 a2 = z( np-4 ) / z( np-2 )
244 IF( z( nn-9 ) .GT. z( nn-11 ) )
245 $ RETURN
246 b2 = z( nn-9 ) / z( nn-11 )
247 np = nn - 13
248 END IF
249*
250* Approximate contribution to norm squared from I < NN-1.
251*
252 a2 = a2 + b2
253 DO 10 i4 = np, 4*i0 - 1 + pp, -4
254 IF( b2.EQ.zero )
255 $ GO TO 20
256 b1 = b2
257 IF( z( i4 ) .GT. z( i4-2 ) )
258 $ RETURN
259 b2 = b2*( z( i4 ) / z( i4-2 ) )
260 a2 = a2 + b2
261 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
262 $ GO TO 20
263 10 CONTINUE
264 20 CONTINUE
265 a2 = cnst3*a2
266*
267* Rayleigh quotient residual bound.
268*
269 IF( a2.LT.cnst1 )
270 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
271 END IF
272 ELSE IF( dmin.EQ.dn2 ) THEN
273*
274* Case 5.
275*
276 ttype = -5
277 s = qurtr*dmin
278*
279* Compute contribution to norm squared from I > NN-2.
280*
281 np = nn - 2*pp
282 b1 = z( np-2 )
283 b2 = z( np-6 )
284 gam = dn2
285 IF( z( np-8 ).GT.b2 .OR. z( np-4 ).GT.b1 )
286 $ RETURN
287 a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 )
288*
289* Approximate contribution to norm squared from I < NN-2.
290*
291 IF( n0-i0.GT.2 ) THEN
292 b2 = z( nn-13 ) / z( nn-15 )
293 a2 = a2 + b2
294 DO 30 i4 = nn - 17, 4*i0 - 1 + pp, -4
295 IF( b2.EQ.zero )
296 $ GO TO 40
297 b1 = b2
298 IF( z( i4 ) .GT. z( i4-2 ) )
299 $ RETURN
300 b2 = b2*( z( i4 ) / z( i4-2 ) )
301 a2 = a2 + b2
302 IF( hundrd*max( b2, b1 ).LT.a2 .OR. cnst1.LT.a2 )
303 $ GO TO 40
304 30 CONTINUE
305 40 CONTINUE
306 a2 = cnst3*a2
307 END IF
308*
309 IF( a2.LT.cnst1 )
310 $ s = gam*( one-sqrt( a2 ) ) / ( one+a2 )
311 ELSE
312*
313* Case 6, no information to guide us.
314*
315 IF( ttype.EQ.-6 ) THEN
316 g = g + third*( one-g )
317 ELSE IF( ttype.EQ.-18 ) THEN
318 g = qurtr*third
319 ELSE
320 g = qurtr
321 END IF
322 s = g*dmin
323 ttype = -6
324 END IF
325*
326 ELSE IF( n0in.EQ.( n0+1 ) ) THEN
327*
328* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
329*
330 IF( dmin1.EQ.dn1 .AND. dmin2.EQ.dn2 ) THEN
331*
332* Cases 7 and 8.
333*
334 ttype = -7
335 s = third*dmin1
336 IF( z( nn-5 ).GT.z( nn-7 ) )
337 $ RETURN
338 b1 = z( nn-5 ) / z( nn-7 )
339 b2 = b1
340 IF( b2.EQ.zero )
341 $ GO TO 60
342 DO 50 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
343 a2 = b1
344 IF( z( i4 ).GT.z( i4-2 ) )
345 $ RETURN
346 b1 = b1*( z( i4 ) / z( i4-2 ) )
347 b2 = b2 + b1
348 IF( hundrd*max( b1, a2 ).LT.b2 )
349 $ GO TO 60
350 50 CONTINUE
351 60 CONTINUE
352 b2 = sqrt( cnst3*b2 )
353 a2 = dmin1 / ( one+b2**2 )
354 gap2 = half*dmin2 - a2
355 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
356 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
357 ELSE
358 s = max( s, a2*( one-cnst2*b2 ) )
359 ttype = -8
360 END IF
361 ELSE
362*
363* Case 9.
364*
365 s = qurtr*dmin1
366 IF( dmin1.EQ.dn1 )
367 $ s = half*dmin1
368 ttype = -9
369 END IF
370*
371 ELSE IF( n0in.EQ.( n0+2 ) ) THEN
372*
373* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
374*
375* Cases 10 and 11.
376*
377 IF( dmin2.EQ.dn2 .AND. two*z( nn-5 ).LT.z( nn-7 ) ) THEN
378 ttype = -10
379 s = third*dmin2
380 IF( z( nn-5 ).GT.z( nn-7 ) )
381 $ RETURN
382 b1 = z( nn-5 ) / z( nn-7 )
383 b2 = b1
384 IF( b2.EQ.zero )
385 $ GO TO 80
386 DO 70 i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4
387 IF( z( i4 ).GT.z( i4-2 ) )
388 $ RETURN
389 b1 = b1*( z( i4 ) / z( i4-2 ) )
390 b2 = b2 + b1
391 IF( hundrd*b1.LT.b2 )
392 $ GO TO 80
393 70 CONTINUE
394 80 CONTINUE
395 b2 = sqrt( cnst3*b2 )
396 a2 = dmin2 / ( one+b2**2 )
397 gap2 = z( nn-7 ) + z( nn-9 ) -
398 $ sqrt( z( nn-11 ) )*sqrt( z( nn-9 ) ) - a2
399 IF( gap2.GT.zero .AND. gap2.GT.b2*a2 ) THEN
400 s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) )
401 ELSE
402 s = max( s, a2*( one-cnst2*b2 ) )
403 END IF
404 ELSE
405 s = qurtr*dmin2
406 ttype = -11
407 END IF
408 ELSE IF( n0in.GT.( n0+2 ) ) THEN
409*
410* Case 12, more than two eigenvalues deflated. No information.
411*
412 s = zero
413 ttype = -12
414 END IF
415*
416 tau = s
417 RETURN
418*
419* End of SLASQ4
420*

◆ slasq5()

subroutine slasq5 ( integer i0,
integer n0,
real, dimension( * ) z,
integer pp,
real tau,
real sigma,
real dmin,
real dmin1,
real dmin2,
real dn,
real dnm1,
real dnm2,
logical ieee,
real eps )

SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> SLASQ5 computes one dqds transform in ping-pong form, one
!> version for IEEE machines another for non IEEE machines.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is REAL array, dimension ( 4*N )
!>        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!>        an extra argument.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[in]TAU
!>          TAU is REAL
!>        This is the shift.
!>
[in]SIGMA
!>          SIGMA is REAL
!>        This is the accumulated shift up to this step.
!>
[out]DMIN
!>          DMIN is REAL
!>        Minimum value of d.
!>
[out]DMIN1
!>          DMIN1 is REAL
!>        Minimum value of d, excluding D( N0 ).
!>
[out]DMIN2
!>          DMIN2 is REAL
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[out]DN
!>          DN is REAL
!>        d(N0), the last value of d.
!>
[out]DNM1
!>          DNM1 is REAL
!>        d(N0-1).
!>
[out]DNM2
!>          DNM2 is REAL
!>        d(N0-2).
!>
[in]IEEE
!>          IEEE is LOGICAL
!>        Flag for IEEE or non IEEE arithmetic.
!>
[in]EPS
!>         EPS is REAL
!>        This is the value of epsilon used.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file slasq5.f.

144*
145* -- LAPACK computational routine --
146* -- LAPACK is a software package provided by Univ. of Tennessee, --
147* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
148*
149* .. Scalar Arguments ..
150 LOGICAL IEEE
151 INTEGER I0, N0, PP
152 REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU,
153 $ SIGMA, EPS
154* ..
155* .. Array Arguments ..
156 REAL Z( * )
157* ..
158*
159* =====================================================================
160*
161* .. Parameter ..
162 REAL ZERO, HALF
163 parameter( zero = 0.0e0, half = 0.5 )
164* ..
165* .. Local Scalars ..
166 INTEGER J4, J4P2
167 REAL D, EMIN, TEMP, DTHRESH
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC min
171* ..
172* .. Executable Statements ..
173*
174 IF( ( n0-i0-1 ).LE.0 )
175 $ RETURN
176*
177 dthresh = eps*(sigma+tau)
178 IF( tau.LT.dthresh*half ) tau = zero
179 IF( tau.NE.zero ) THEN
180 j4 = 4*i0 + pp - 3
181 emin = z( j4+4 )
182 d = z( j4 ) - tau
183 dmin = d
184 dmin1 = -z( j4 )
185*
186 IF( ieee ) THEN
187*
188* Code for IEEE arithmetic.
189*
190 IF( pp.EQ.0 ) THEN
191 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
192 z( j4-2 ) = d + z( j4-1 )
193 temp = z( j4+1 ) / z( j4-2 )
194 d = d*temp - tau
195 dmin = min( dmin, d )
196 z( j4 ) = z( j4-1 )*temp
197 emin = min( z( j4 ), emin )
198 10 CONTINUE
199 ELSE
200 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
201 z( j4-3 ) = d + z( j4 )
202 temp = z( j4+2 ) / z( j4-3 )
203 d = d*temp - tau
204 dmin = min( dmin, d )
205 z( j4-1 ) = z( j4 )*temp
206 emin = min( z( j4-1 ), emin )
207 20 CONTINUE
208 END IF
209*
210* Unroll last two steps.
211*
212 dnm2 = d
213 dmin2 = dmin
214 j4 = 4*( n0-2 ) - pp
215 j4p2 = j4 + 2*pp - 1
216 z( j4-2 ) = dnm2 + z( j4p2 )
217 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
218 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
219 dmin = min( dmin, dnm1 )
220*
221 dmin1 = dmin
222 j4 = j4 + 4
223 j4p2 = j4 + 2*pp - 1
224 z( j4-2 ) = dnm1 + z( j4p2 )
225 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
226 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
227 dmin = min( dmin, dn )
228*
229 ELSE
230*
231* Code for non IEEE arithmetic.
232*
233 IF( pp.EQ.0 ) THEN
234 DO 30 j4 = 4*i0, 4*( n0-3 ), 4
235 z( j4-2 ) = d + z( j4-1 )
236 IF( d.LT.zero ) THEN
237 RETURN
238 ELSE
239 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
240 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
241 END IF
242 dmin = min( dmin, d )
243 emin = min( emin, z( j4 ) )
244 30 CONTINUE
245 ELSE
246 DO 40 j4 = 4*i0, 4*( n0-3 ), 4
247 z( j4-3 ) = d + z( j4 )
248 IF( d.LT.zero ) THEN
249 RETURN
250 ELSE
251 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
252 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
253 END IF
254 dmin = min( dmin, d )
255 emin = min( emin, z( j4-1 ) )
256 40 CONTINUE
257 END IF
258*
259* Unroll last two steps.
260*
261 dnm2 = d
262 dmin2 = dmin
263 j4 = 4*( n0-2 ) - pp
264 j4p2 = j4 + 2*pp - 1
265 z( j4-2 ) = dnm2 + z( j4p2 )
266 IF( dnm2.LT.zero ) THEN
267 RETURN
268 ELSE
269 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
270 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
271 END IF
272 dmin = min( dmin, dnm1 )
273*
274 dmin1 = dmin
275 j4 = j4 + 4
276 j4p2 = j4 + 2*pp - 1
277 z( j4-2 ) = dnm1 + z( j4p2 )
278 IF( dnm1.LT.zero ) THEN
279 RETURN
280 ELSE
281 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
282 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
283 END IF
284 dmin = min( dmin, dn )
285*
286 END IF
287*
288 ELSE
289* This is the version that sets d's to zero if they are small enough
290 j4 = 4*i0 + pp - 3
291 emin = z( j4+4 )
292 d = z( j4 ) - tau
293 dmin = d
294 dmin1 = -z( j4 )
295 IF( ieee ) THEN
296*
297* Code for IEEE arithmetic.
298*
299 IF( pp.EQ.0 ) THEN
300 DO 50 j4 = 4*i0, 4*( n0-3 ), 4
301 z( j4-2 ) = d + z( j4-1 )
302 temp = z( j4+1 ) / z( j4-2 )
303 d = d*temp - tau
304 IF( d.LT.dthresh ) d = zero
305 dmin = min( dmin, d )
306 z( j4 ) = z( j4-1 )*temp
307 emin = min( z( j4 ), emin )
308 50 CONTINUE
309 ELSE
310 DO 60 j4 = 4*i0, 4*( n0-3 ), 4
311 z( j4-3 ) = d + z( j4 )
312 temp = z( j4+2 ) / z( j4-3 )
313 d = d*temp - tau
314 IF( d.LT.dthresh ) d = zero
315 dmin = min( dmin, d )
316 z( j4-1 ) = z( j4 )*temp
317 emin = min( z( j4-1 ), emin )
318 60 CONTINUE
319 END IF
320*
321* Unroll last two steps.
322*
323 dnm2 = d
324 dmin2 = dmin
325 j4 = 4*( n0-2 ) - pp
326 j4p2 = j4 + 2*pp - 1
327 z( j4-2 ) = dnm2 + z( j4p2 )
328 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
329 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
330 dmin = min( dmin, dnm1 )
331*
332 dmin1 = dmin
333 j4 = j4 + 4
334 j4p2 = j4 + 2*pp - 1
335 z( j4-2 ) = dnm1 + z( j4p2 )
336 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
337 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
338 dmin = min( dmin, dn )
339*
340 ELSE
341*
342* Code for non IEEE arithmetic.
343*
344 IF( pp.EQ.0 ) THEN
345 DO 70 j4 = 4*i0, 4*( n0-3 ), 4
346 z( j4-2 ) = d + z( j4-1 )
347 IF( d.LT.zero ) THEN
348 RETURN
349 ELSE
350 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
351 d = z( j4+1 )*( d / z( j4-2 ) ) - tau
352 END IF
353 IF( d.LT.dthresh ) d = zero
354 dmin = min( dmin, d )
355 emin = min( emin, z( j4 ) )
356 70 CONTINUE
357 ELSE
358 DO 80 j4 = 4*i0, 4*( n0-3 ), 4
359 z( j4-3 ) = d + z( j4 )
360 IF( d.LT.zero ) THEN
361 RETURN
362 ELSE
363 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
364 d = z( j4+2 )*( d / z( j4-3 ) ) - tau
365 END IF
366 IF( d.LT.dthresh ) d = zero
367 dmin = min( dmin, d )
368 emin = min( emin, z( j4-1 ) )
369 80 CONTINUE
370 END IF
371*
372* Unroll last two steps.
373*
374 dnm2 = d
375 dmin2 = dmin
376 j4 = 4*( n0-2 ) - pp
377 j4p2 = j4 + 2*pp - 1
378 z( j4-2 ) = dnm2 + z( j4p2 )
379 IF( dnm2.LT.zero ) THEN
380 RETURN
381 ELSE
382 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
383 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) ) - tau
384 END IF
385 dmin = min( dmin, dnm1 )
386*
387 dmin1 = dmin
388 j4 = j4 + 4
389 j4p2 = j4 + 2*pp - 1
390 z( j4-2 ) = dnm1 + z( j4p2 )
391 IF( dnm1.LT.zero ) THEN
392 RETURN
393 ELSE
394 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
395 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) ) - tau
396 END IF
397 dmin = min( dmin, dn )
398*
399 END IF
400*
401 END IF
402 z( j4+2 ) = dn
403 z( 4*n0-pp ) = emin
404 RETURN
405*
406* End of SLASQ5
407*

◆ slasq6()

subroutine slasq6 ( integer i0,
integer n0,
real, dimension( * ) z,
integer pp,
real dmin,
real dmin1,
real dmin2,
real dn,
real dnm1,
real dnm2 )

SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr.

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

Purpose:
!>
!> SLASQ6 computes one dqd (shift equal to zero) transform in
!> ping-pong form, with protection against underflow and overflow.
!>
Parameters
[in]I0
!>          I0 is INTEGER
!>        First index.
!>
[in]N0
!>          N0 is INTEGER
!>        Last index.
!>
[in]Z
!>          Z is REAL array, dimension ( 4*N )
!>        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
!>        an extra argument.
!>
[in]PP
!>          PP is INTEGER
!>        PP=0 for ping, PP=1 for pong.
!>
[out]DMIN
!>          DMIN is REAL
!>        Minimum value of d.
!>
[out]DMIN1
!>          DMIN1 is REAL
!>        Minimum value of d, excluding D( N0 ).
!>
[out]DMIN2
!>          DMIN2 is REAL
!>        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
!>
[out]DN
!>          DN is REAL
!>        d(N0), the last value of d.
!>
[out]DNM1
!>          DNM1 is REAL
!>        d(N0-1).
!>
[out]DNM2
!>          DNM2 is REAL
!>        d(N0-2).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file slasq6.f.

119*
120* -- LAPACK computational routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER I0, N0, PP
126 REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
127* ..
128* .. Array Arguments ..
129 REAL Z( * )
130* ..
131*
132* =====================================================================
133*
134* .. Parameter ..
135 REAL ZERO
136 parameter( zero = 0.0e0 )
137* ..
138* .. Local Scalars ..
139 INTEGER J4, J4P2
140 REAL D, EMIN, SAFMIN, TEMP
141* ..
142* .. External Function ..
143 REAL SLAMCH
144 EXTERNAL slamch
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC min
148* ..
149* .. Executable Statements ..
150*
151 IF( ( n0-i0-1 ).LE.0 )
152 $ RETURN
153*
154 safmin = slamch( 'Safe minimum' )
155 j4 = 4*i0 + pp - 3
156 emin = z( j4+4 )
157 d = z( j4 )
158 dmin = d
159*
160 IF( pp.EQ.0 ) THEN
161 DO 10 j4 = 4*i0, 4*( n0-3 ), 4
162 z( j4-2 ) = d + z( j4-1 )
163 IF( z( j4-2 ).EQ.zero ) THEN
164 z( j4 ) = zero
165 d = z( j4+1 )
166 dmin = d
167 emin = zero
168 ELSE IF( safmin*z( j4+1 ).LT.z( j4-2 ) .AND.
169 $ safmin*z( j4-2 ).LT.z( j4+1 ) ) THEN
170 temp = z( j4+1 ) / z( j4-2 )
171 z( j4 ) = z( j4-1 )*temp
172 d = d*temp
173 ELSE
174 z( j4 ) = z( j4+1 )*( z( j4-1 ) / z( j4-2 ) )
175 d = z( j4+1 )*( d / z( j4-2 ) )
176 END IF
177 dmin = min( dmin, d )
178 emin = min( emin, z( j4 ) )
179 10 CONTINUE
180 ELSE
181 DO 20 j4 = 4*i0, 4*( n0-3 ), 4
182 z( j4-3 ) = d + z( j4 )
183 IF( z( j4-3 ).EQ.zero ) THEN
184 z( j4-1 ) = zero
185 d = z( j4+2 )
186 dmin = d
187 emin = zero
188 ELSE IF( safmin*z( j4+2 ).LT.z( j4-3 ) .AND.
189 $ safmin*z( j4-3 ).LT.z( j4+2 ) ) THEN
190 temp = z( j4+2 ) / z( j4-3 )
191 z( j4-1 ) = z( j4 )*temp
192 d = d*temp
193 ELSE
194 z( j4-1 ) = z( j4+2 )*( z( j4 ) / z( j4-3 ) )
195 d = z( j4+2 )*( d / z( j4-3 ) )
196 END IF
197 dmin = min( dmin, d )
198 emin = min( emin, z( j4-1 ) )
199 20 CONTINUE
200 END IF
201*
202* Unroll last two steps.
203*
204 dnm2 = d
205 dmin2 = dmin
206 j4 = 4*( n0-2 ) - pp
207 j4p2 = j4 + 2*pp - 1
208 z( j4-2 ) = dnm2 + z( j4p2 )
209 IF( z( j4-2 ).EQ.zero ) THEN
210 z( j4 ) = zero
211 dnm1 = z( j4p2+2 )
212 dmin = dnm1
213 emin = zero
214 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
215 $ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
216 temp = z( j4p2+2 ) / z( j4-2 )
217 z( j4 ) = z( j4p2 )*temp
218 dnm1 = dnm2*temp
219 ELSE
220 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
221 dnm1 = z( j4p2+2 )*( dnm2 / z( j4-2 ) )
222 END IF
223 dmin = min( dmin, dnm1 )
224*
225 dmin1 = dmin
226 j4 = j4 + 4
227 j4p2 = j4 + 2*pp - 1
228 z( j4-2 ) = dnm1 + z( j4p2 )
229 IF( z( j4-2 ).EQ.zero ) THEN
230 z( j4 ) = zero
231 dn = z( j4p2+2 )
232 dmin = dn
233 emin = zero
234 ELSE IF( safmin*z( j4p2+2 ).LT.z( j4-2 ) .AND.
235 $ safmin*z( j4-2 ).LT.z( j4p2+2 ) ) THEN
236 temp = z( j4p2+2 ) / z( j4-2 )
237 z( j4 ) = z( j4p2 )*temp
238 dn = dnm1*temp
239 ELSE
240 z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) )
241 dn = z( j4p2+2 )*( dnm1 / z( j4-2 ) )
242 END IF
243 dmin = min( dmin, dn )
244*
245 z( j4+2 ) = dn
246 z( 4*n0-pp ) = emin
247 RETURN
248*
249* End of SLASQ6
250*

◆ slasrt()

subroutine slasrt ( character id,
integer n,
real, dimension( * ) d,
integer info )

SLASRT sorts numbers in increasing or decreasing order.

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

Purpose:
!>
!> Sort the numbers in D in increasing order (if ID = 'I') or
!> in decreasing order (if ID = 'D' ).
!>
!> Use Quick Sort, reverting to Insertion sort on arrays of
!> size <= 20. Dimension of STACK limits N to about 2**32.
!>
Parameters
[in]ID
!>          ID is CHARACTER*1
!>          = 'I': sort D in increasing order;
!>          = 'D': sort D in decreasing order.
!>
[in]N
!>          N is INTEGER
!>          The length of the array D.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the array to be sorted.
!>          On exit, D has been sorted into increasing order
!>          (D(1) <= ... <= D(N) ) or into decreasing order
!>          (D(1) >= ... >= D(N) ), depending on ID.
!>
[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 87 of file slasrt.f.

88*
89* -- LAPACK computational routine --
90* -- LAPACK is a software package provided by Univ. of Tennessee, --
91* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92*
93* .. Scalar Arguments ..
94 CHARACTER ID
95 INTEGER INFO, N
96* ..
97* .. Array Arguments ..
98 REAL D( * )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 INTEGER SELECT
105 parameter( SELECT = 20 )
106* ..
107* .. Local Scalars ..
108 INTEGER DIR, ENDD, I, J, START, STKPNT
109 REAL D1, D2, D3, DMNMX, TMP
110* ..
111* .. Local Arrays ..
112 INTEGER STACK( 2, 32 )
113* ..
114* .. External Functions ..
115 LOGICAL LSAME
116 EXTERNAL lsame
117* ..
118* .. External Subroutines ..
119 EXTERNAL xerbla
120* ..
121* .. Executable Statements ..
122*
123* Test the input parameters.
124*
125 info = 0
126 dir = -1
127 IF( lsame( id, 'D' ) ) THEN
128 dir = 0
129 ELSE IF( lsame( id, 'I' ) ) THEN
130 dir = 1
131 END IF
132 IF( dir.EQ.-1 ) THEN
133 info = -1
134 ELSE IF( n.LT.0 ) THEN
135 info = -2
136 END IF
137 IF( info.NE.0 ) THEN
138 CALL xerbla( 'SLASRT', -info )
139 RETURN
140 END IF
141*
142* Quick return if possible
143*
144 IF( n.LE.1 )
145 $ RETURN
146*
147 stkpnt = 1
148 stack( 1, 1 ) = 1
149 stack( 2, 1 ) = n
150 10 CONTINUE
151 start = stack( 1, stkpnt )
152 endd = stack( 2, stkpnt )
153 stkpnt = stkpnt - 1
154 IF( endd-start.LE.SELECT .AND. endd-start.GT.0 ) THEN
155*
156* Do Insertion sort on D( START:ENDD )
157*
158 IF( dir.EQ.0 ) THEN
159*
160* Sort into decreasing order
161*
162 DO 30 i = start + 1, endd
163 DO 20 j = i, start + 1, -1
164 IF( d( j ).GT.d( j-1 ) ) THEN
165 dmnmx = d( j )
166 d( j ) = d( j-1 )
167 d( j-1 ) = dmnmx
168 ELSE
169 GO TO 30
170 END IF
171 20 CONTINUE
172 30 CONTINUE
173*
174 ELSE
175*
176* Sort into increasing order
177*
178 DO 50 i = start + 1, endd
179 DO 40 j = i, start + 1, -1
180 IF( d( j ).LT.d( j-1 ) ) THEN
181 dmnmx = d( j )
182 d( j ) = d( j-1 )
183 d( j-1 ) = dmnmx
184 ELSE
185 GO TO 50
186 END IF
187 40 CONTINUE
188 50 CONTINUE
189*
190 END IF
191*
192 ELSE IF( endd-start.GT.SELECT ) THEN
193*
194* Partition D( START:ENDD ) and stack parts, largest one first
195*
196* Choose partition entry as median of 3
197*
198 d1 = d( start )
199 d2 = d( endd )
200 i = ( start+endd ) / 2
201 d3 = d( i )
202 IF( d1.LT.d2 ) THEN
203 IF( d3.LT.d1 ) THEN
204 dmnmx = d1
205 ELSE IF( d3.LT.d2 ) THEN
206 dmnmx = d3
207 ELSE
208 dmnmx = d2
209 END IF
210 ELSE
211 IF( d3.LT.d2 ) THEN
212 dmnmx = d2
213 ELSE IF( d3.LT.d1 ) THEN
214 dmnmx = d3
215 ELSE
216 dmnmx = d1
217 END IF
218 END IF
219*
220 IF( dir.EQ.0 ) THEN
221*
222* Sort into decreasing order
223*
224 i = start - 1
225 j = endd + 1
226 60 CONTINUE
227 70 CONTINUE
228 j = j - 1
229 IF( d( j ).LT.dmnmx )
230 $ GO TO 70
231 80 CONTINUE
232 i = i + 1
233 IF( d( i ).GT.dmnmx )
234 $ GO TO 80
235 IF( i.LT.j ) THEN
236 tmp = d( i )
237 d( i ) = d( j )
238 d( j ) = tmp
239 GO TO 60
240 END IF
241 IF( j-start.GT.endd-j-1 ) THEN
242 stkpnt = stkpnt + 1
243 stack( 1, stkpnt ) = start
244 stack( 2, stkpnt ) = j
245 stkpnt = stkpnt + 1
246 stack( 1, stkpnt ) = j + 1
247 stack( 2, stkpnt ) = endd
248 ELSE
249 stkpnt = stkpnt + 1
250 stack( 1, stkpnt ) = j + 1
251 stack( 2, stkpnt ) = endd
252 stkpnt = stkpnt + 1
253 stack( 1, stkpnt ) = start
254 stack( 2, stkpnt ) = j
255 END IF
256 ELSE
257*
258* Sort into increasing order
259*
260 i = start - 1
261 j = endd + 1
262 90 CONTINUE
263 100 CONTINUE
264 j = j - 1
265 IF( d( j ).GT.dmnmx )
266 $ GO TO 100
267 110 CONTINUE
268 i = i + 1
269 IF( d( i ).LT.dmnmx )
270 $ GO TO 110
271 IF( i.LT.j ) THEN
272 tmp = d( i )
273 d( i ) = d( j )
274 d( j ) = tmp
275 GO TO 90
276 END IF
277 IF( j-start.GT.endd-j-1 ) THEN
278 stkpnt = stkpnt + 1
279 stack( 1, stkpnt ) = start
280 stack( 2, stkpnt ) = j
281 stkpnt = stkpnt + 1
282 stack( 1, stkpnt ) = j + 1
283 stack( 2, stkpnt ) = endd
284 ELSE
285 stkpnt = stkpnt + 1
286 stack( 1, stkpnt ) = j + 1
287 stack( 2, stkpnt ) = endd
288 stkpnt = stkpnt + 1
289 stack( 1, stkpnt ) = start
290 stack( 2, stkpnt ) = j
291 END IF
292 END IF
293 END IF
294 IF( stkpnt.GT.0 )
295 $ GO TO 10
296 RETURN
297*
298* End of SLASRT
299*

◆ spttrf()

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

SPTTRF

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

Purpose:
!>
!> SPTTRF computes the L*D*L**T factorization of a real symmetric
!> positive definite tridiagonal matrix A.  The factorization may also
!> be regarded as having the form A = U**T*D*U.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the n diagonal elements of the tridiagonal matrix
!>          A.  On exit, the n diagonal elements of the diagonal matrix
!>          D from the L*D*L**T factorization of A.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix A.  On exit, the (n-1) subdiagonal elements of the
!>          unit bidiagonal factor L from the L*D*L**T factorization of A.
!>          E can also be regarded as the superdiagonal of the unit
!>          bidiagonal factor U from the U**T*D*U factorization of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, the leading minor of order k is not
!>               positive definite; if k < N, the factorization could not
!>               be completed, while if k = N, the factorization was
!>               completed, but D(N) <= 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file spttrf.f.

91*
92* -- LAPACK computational routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER INFO, N
98* ..
99* .. Array Arguments ..
100 REAL D( * ), E( * )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 REAL ZERO
107 parameter( zero = 0.0e+0 )
108* ..
109* .. Local Scalars ..
110 INTEGER I, I4
111 REAL EI
112* ..
113* .. External Subroutines ..
114 EXTERNAL xerbla
115* ..
116* .. Intrinsic Functions ..
117 INTRINSIC mod
118* ..
119* .. Executable Statements ..
120*
121* Test the input parameters.
122*
123 info = 0
124 IF( n.LT.0 ) THEN
125 info = -1
126 CALL xerbla( 'SPTTRF', -info )
127 RETURN
128 END IF
129*
130* Quick return if possible
131*
132 IF( n.EQ.0 )
133 $ RETURN
134*
135* Compute the L*D*L**T (or U**T*D*U) factorization of A.
136*
137 i4 = mod( n-1, 4 )
138 DO 10 i = 1, i4
139 IF( d( i ).LE.zero ) THEN
140 info = i
141 GO TO 30
142 END IF
143 ei = e( i )
144 e( i ) = ei / d( i )
145 d( i+1 ) = d( i+1 ) - e( i )*ei
146 10 CONTINUE
147*
148 DO 20 i = i4 + 1, n - 4, 4
149*
150* Drop out of the loop if d(i) <= 0: the matrix is not positive
151* definite.
152*
153 IF( d( i ).LE.zero ) THEN
154 info = i
155 GO TO 30
156 END IF
157*
158* Solve for e(i) and d(i+1).
159*
160 ei = e( i )
161 e( i ) = ei / d( i )
162 d( i+1 ) = d( i+1 ) - e( i )*ei
163*
164 IF( d( i+1 ).LE.zero ) THEN
165 info = i + 1
166 GO TO 30
167 END IF
168*
169* Solve for e(i+1) and d(i+2).
170*
171 ei = e( i+1 )
172 e( i+1 ) = ei / d( i+1 )
173 d( i+2 ) = d( i+2 ) - e( i+1 )*ei
174*
175 IF( d( i+2 ).LE.zero ) THEN
176 info = i + 2
177 GO TO 30
178 END IF
179*
180* Solve for e(i+2) and d(i+3).
181*
182 ei = e( i+2 )
183 e( i+2 ) = ei / d( i+2 )
184 d( i+3 ) = d( i+3 ) - e( i+2 )*ei
185*
186 IF( d( i+3 ).LE.zero ) THEN
187 info = i + 3
188 GO TO 30
189 END IF
190*
191* Solve for e(i+3) and d(i+4).
192*
193 ei = e( i+3 )
194 e( i+3 ) = ei / d( i+3 )
195 d( i+4 ) = d( i+4 ) - e( i+3 )*ei
196 20 CONTINUE
197*
198* Check d(n) for positive definiteness.
199*
200 IF( d( n ).LE.zero )
201 $ info = n
202*
203 30 CONTINUE
204 RETURN
205*
206* End of SPTTRF
207*

◆ sstebz()

subroutine sstebz ( character range,
character order,
integer n,
real vl,
real vu,
integer il,
integer iu,
real abstol,
real, dimension( * ) d,
real, dimension( * ) e,
integer m,
integer nsplit,
real, dimension( * ) w,
integer, dimension( * ) iblock,
integer, dimension( * ) isplit,
real, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

SSTEBZ

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

Purpose:
!>
!> SSTEBZ computes the eigenvalues of a symmetric tridiagonal
!> matrix T.  The user may ask for all eigenvalues, all eigenvalues
!> in the half-open interval (VL, VU], or the IL-th through IU-th
!> eigenvalues.
!>
!> To avoid overflow, the matrix must be scaled so that its
!> largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest
!> accuracy, it should not be much smaller than that.
!>
!> See W. Kahan , 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]ABSTOL
!>          ABSTOL is REAL
!>          The absolute tolerance for the eigenvalues.  An eigenvalue
!>          (or cluster) is considered to be located if it has been
!>          determined to lie in an interval whose width is ABSTOL or
!>          less.  If ABSTOL is less than or equal to zero, then ULP*|T|
!>          will be used, where |T| means the 1-norm of T.
!>
!>          Eigenvalues will be computed most accurately when ABSTOL is
!>          set to twice the underflow threshold 2*SLAMCH('S'), not zero.
!>
[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.
!>
[out]M
!>          M is INTEGER
!>          The actual number of eigenvalues found. 0 <= M <= N.
!>          (See also the description of INFO=2,3.)
!>
[out]NSPLIT
!>          NSPLIT is INTEGER
!>          The number of diagonal blocks in the matrix T.
!>          1 <= NSPLIT <= N.
!>
[out]W
!>          W is REAL array, dimension (N)
!>          On exit, the first M elements of W will contain the
!>          eigenvalues.  (SSTEBZ may use the remaining N-M elements as
!>          workspace.)
!>
[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.  (SSTEBZ may use the remaining N-M elements as
!>          workspace.)
!>
[out]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]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:
!>  RELFAC  REAL, default = 2.0e0
!>          The relative tolerance.  An interval (a,b] lies within
!>           if  b-a < RELFAC*ulp*max(|a|,|b|),
!>          where  is the machine precision (distance from 1 to
!>          the next larger floating point number.)
!>
!>  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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 270 of file sstebz.f.

273*
274* -- LAPACK computational routine --
275* -- LAPACK is a software package provided by Univ. of Tennessee, --
276* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
277*
278* .. Scalar Arguments ..
279 CHARACTER ORDER, RANGE
280 INTEGER IL, INFO, IU, M, N, NSPLIT
281 REAL ABSTOL, VL, VU
282* ..
283* .. Array Arguments ..
284 INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
285 REAL D( * ), E( * ), W( * ), WORK( * )
286* ..
287*
288* =====================================================================
289*
290* .. Parameters ..
291 REAL ZERO, ONE, TWO, HALF
292 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
293 $ half = 1.0e0 / two )
294 REAL FUDGE, RELFAC
295 parameter( fudge = 2.1e0, relfac = 2.0e0 )
296* ..
297* .. Local Scalars ..
298 LOGICAL NCNVRG, TOOFEW
299 INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
300 $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
301 $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
302 $ NWU
303 REAL ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
304 $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
305* ..
306* .. Local Arrays ..
307 INTEGER IDUMMA( 1 )
308* ..
309* .. External Functions ..
310 LOGICAL LSAME
311 INTEGER ILAENV
312 REAL SLAMCH
313 EXTERNAL lsame, ilaenv, slamch
314* ..
315* .. External Subroutines ..
316 EXTERNAL slaebz, xerbla
317* ..
318* .. Intrinsic Functions ..
319 INTRINSIC abs, int, log, max, min, sqrt
320* ..
321* .. Executable Statements ..
322*
323 info = 0
324*
325* Decode RANGE
326*
327 IF( lsame( range, 'A' ) ) THEN
328 irange = 1
329 ELSE IF( lsame( range, 'V' ) ) THEN
330 irange = 2
331 ELSE IF( lsame( range, 'I' ) ) THEN
332 irange = 3
333 ELSE
334 irange = 0
335 END IF
336*
337* Decode ORDER
338*
339 IF( lsame( order, 'B' ) ) THEN
340 iorder = 2
341 ELSE IF( lsame( order, 'E' ) ) THEN
342 iorder = 1
343 ELSE
344 iorder = 0
345 END IF
346*
347* Check for Errors
348*
349 IF( irange.LE.0 ) THEN
350 info = -1
351 ELSE IF( iorder.LE.0 ) THEN
352 info = -2
353 ELSE IF( n.LT.0 ) THEN
354 info = -3
355 ELSE IF( irange.EQ.2 ) THEN
356 IF( vl.GE.vu ) info = -5
357 ELSE IF( irange.EQ.3 .AND. ( il.LT.1 .OR. il.GT.max( 1, n ) ) )
358 $ THEN
359 info = -6
360 ELSE IF( irange.EQ.3 .AND. ( iu.LT.min( n, il ) .OR. iu.GT.n ) )
361 $ THEN
362 info = -7
363 END IF
364*
365 IF( info.NE.0 ) THEN
366 CALL xerbla( 'SSTEBZ', -info )
367 RETURN
368 END IF
369*
370* Initialize error flags
371*
372 info = 0
373 ncnvrg = .false.
374 toofew = .false.
375*
376* Quick return if possible
377*
378 m = 0
379 IF( n.EQ.0 )
380 $ RETURN
381*
382* Simplifications:
383*
384 IF( irange.EQ.3 .AND. il.EQ.1 .AND. iu.EQ.n )
385 $ irange = 1
386*
387* Get machine constants
388* NB is the minimum vector length for vector bisection, or 0
389* if only scalar is to be done.
390*
391 safemn = slamch( 'S' )
392 ulp = slamch( 'P' )
393 rtoli = ulp*relfac
394 nb = ilaenv( 1, 'SSTEBZ', ' ', n, -1, -1, -1 )
395 IF( nb.LE.1 )
396 $ nb = 0
397*
398* Special Case when N=1
399*
400 IF( n.EQ.1 ) THEN
401 nsplit = 1
402 isplit( 1 ) = 1
403 IF( irange.EQ.2 .AND. ( vl.GE.d( 1 ) .OR. vu.LT.d( 1 ) ) ) THEN
404 m = 0
405 ELSE
406 w( 1 ) = d( 1 )
407 iblock( 1 ) = 1
408 m = 1
409 END IF
410 RETURN
411 END IF
412*
413* Compute Splitting Points
414*
415 nsplit = 1
416 work( n ) = zero
417 pivmin = one
418*
419 DO 10 j = 2, n
420 tmp1 = e( j-1 )**2
421 IF( abs( d( j )*d( j-1 ) )*ulp**2+safemn.GT.tmp1 ) THEN
422 isplit( nsplit ) = j - 1
423 nsplit = nsplit + 1
424 work( j-1 ) = zero
425 ELSE
426 work( j-1 ) = tmp1
427 pivmin = max( pivmin, tmp1 )
428 END IF
429 10 CONTINUE
430 isplit( nsplit ) = n
431 pivmin = pivmin*safemn
432*
433* Compute Interval and ATOLI
434*
435 IF( irange.EQ.3 ) THEN
436*
437* RANGE='I': Compute the interval containing eigenvalues
438* IL through IU.
439*
440* Compute Gershgorin interval for entire (split) matrix
441* and use it as the initial interval
442*
443 gu = d( 1 )
444 gl = d( 1 )
445 tmp1 = zero
446*
447 DO 20 j = 1, n - 1
448 tmp2 = sqrt( work( j ) )
449 gu = max( gu, d( j )+tmp1+tmp2 )
450 gl = min( gl, d( j )-tmp1-tmp2 )
451 tmp1 = tmp2
452 20 CONTINUE
453*
454 gu = max( gu, d( n )+tmp1 )
455 gl = min( gl, d( n )-tmp1 )
456 tnorm = max( abs( gl ), abs( gu ) )
457 gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin
458 gu = gu + fudge*tnorm*ulp*n + fudge*pivmin
459*
460* Compute Iteration parameters
461*
462 itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /
463 $ log( two ) ) + 2
464 IF( abstol.LE.zero ) THEN
465 atoli = ulp*tnorm
466 ELSE
467 atoli = abstol
468 END IF
469*
470 work( n+1 ) = gl
471 work( n+2 ) = gl
472 work( n+3 ) = gu
473 work( n+4 ) = gu
474 work( n+5 ) = gl
475 work( n+6 ) = gu
476 iwork( 1 ) = -1
477 iwork( 2 ) = -1
478 iwork( 3 ) = n + 1
479 iwork( 4 ) = n + 1
480 iwork( 5 ) = il - 1
481 iwork( 6 ) = iu
482*
483 CALL slaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin, d, e,
484 $ work, iwork( 5 ), work( n+1 ), work( n+5 ), iout,
485 $ iwork, w, iblock, iinfo )
486*
487 IF( iwork( 6 ).EQ.iu ) THEN
488 wl = work( n+1 )
489 wlu = work( n+3 )
490 nwl = iwork( 1 )
491 wu = work( n+4 )
492 wul = work( n+2 )
493 nwu = iwork( 4 )
494 ELSE
495 wl = work( n+2 )
496 wlu = work( n+4 )
497 nwl = iwork( 2 )
498 wu = work( n+3 )
499 wul = work( n+1 )
500 nwu = iwork( 3 )
501 END IF
502*
503 IF( nwl.LT.0 .OR. nwl.GE.n .OR. nwu.LT.1 .OR. nwu.GT.n ) THEN
504 info = 4
505 RETURN
506 END IF
507 ELSE
508*
509* RANGE='A' or 'V' -- Set ATOLI
510*
511 tnorm = max( abs( d( 1 ) )+abs( e( 1 ) ),
512 $ abs( d( n ) )+abs( e( n-1 ) ) )
513*
514 DO 30 j = 2, n - 1
515 tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+
516 $ abs( e( j ) ) )
517 30 CONTINUE
518*
519 IF( abstol.LE.zero ) THEN
520 atoli = ulp*tnorm
521 ELSE
522 atoli = abstol
523 END IF
524*
525 IF( irange.EQ.2 ) THEN
526 wl = vl
527 wu = vu
528 ELSE
529 wl = zero
530 wu = zero
531 END IF
532 END IF
533*
534* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
535* NWL accumulates the number of eigenvalues .le. WL,
536* NWU accumulates the number of eigenvalues .le. WU
537*
538 m = 0
539 iend = 0
540 info = 0
541 nwl = 0
542 nwu = 0
543*
544 DO 70 jb = 1, nsplit
545 ioff = iend
546 ibegin = ioff + 1
547 iend = isplit( jb )
548 in = iend - ioff
549*
550 IF( in.EQ.1 ) THEN
551*
552* Special Case -- IN=1
553*
554 IF( irange.EQ.1 .OR. wl.GE.d( ibegin )-pivmin )
555 $ nwl = nwl + 1
556 IF( irange.EQ.1 .OR. wu.GE.d( ibegin )-pivmin )
557 $ nwu = nwu + 1
558 IF( irange.EQ.1 .OR. ( wl.LT.d( ibegin )-pivmin .AND. wu.GE.
559 $ d( ibegin )-pivmin ) ) THEN
560 m = m + 1
561 w( m ) = d( ibegin )
562 iblock( m ) = jb
563 END IF
564 ELSE
565*
566* General Case -- IN > 1
567*
568* Compute Gershgorin Interval
569* and use it as the initial interval
570*
571 gu = d( ibegin )
572 gl = d( ibegin )
573 tmp1 = zero
574*
575 DO 40 j = ibegin, iend - 1
576 tmp2 = abs( e( j ) )
577 gu = max( gu, d( j )+tmp1+tmp2 )
578 gl = min( gl, d( j )-tmp1-tmp2 )
579 tmp1 = tmp2
580 40 CONTINUE
581*
582 gu = max( gu, d( iend )+tmp1 )
583 gl = min( gl, d( iend )-tmp1 )
584 bnorm = max( abs( gl ), abs( gu ) )
585 gl = gl - fudge*bnorm*ulp*in - fudge*pivmin
586 gu = gu + fudge*bnorm*ulp*in + fudge*pivmin
587*
588* Compute ATOLI for the current submatrix
589*
590 IF( abstol.LE.zero ) THEN
591 atoli = ulp*max( abs( gl ), abs( gu ) )
592 ELSE
593 atoli = abstol
594 END IF
595*
596 IF( irange.GT.1 ) THEN
597 IF( gu.LT.wl ) THEN
598 nwl = nwl + in
599 nwu = nwu + in
600 GO TO 70
601 END IF
602 gl = max( gl, wl )
603 gu = min( gu, wu )
604 IF( gl.GE.gu )
605 $ GO TO 70
606 END IF
607*
608* Set Up Initial Interval
609*
610 work( n+1 ) = gl
611 work( n+in+1 ) = gu
612 CALL slaebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,
613 $ d( ibegin ), e( ibegin ), work( ibegin ),
614 $ idumma, work( n+1 ), work( n+2*in+1 ), im,
615 $ iwork, w( m+1 ), iblock( m+1 ), iinfo )
616*
617 nwl = nwl + iwork( 1 )
618 nwu = nwu + iwork( in+1 )
619 iwoff = m - iwork( 1 )
620*
621* Compute Eigenvalues
622*
623 itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /
624 $ log( two ) ) + 2
625 CALL slaebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,
626 $ d( ibegin ), e( ibegin ), work( ibegin ),
627 $ idumma, work( n+1 ), work( n+2*in+1 ), iout,
628 $ iwork, w( m+1 ), iblock( m+1 ), iinfo )
629*
630* Copy Eigenvalues Into W and IBLOCK
631* Use -JB for block number for unconverged eigenvalues.
632*
633 DO 60 j = 1, iout
634 tmp1 = half*( work( j+n )+work( j+in+n ) )
635*
636* Flag non-convergence.
637*
638 IF( j.GT.iout-iinfo ) THEN
639 ncnvrg = .true.
640 ib = -jb
641 ELSE
642 ib = jb
643 END IF
644 DO 50 je = iwork( j ) + 1 + iwoff,
645 $ iwork( j+in ) + iwoff
646 w( je ) = tmp1
647 iblock( je ) = ib
648 50 CONTINUE
649 60 CONTINUE
650*
651 m = m + im
652 END IF
653 70 CONTINUE
654*
655* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
656* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
657*
658 IF( irange.EQ.3 ) THEN
659 im = 0
660 idiscl = il - 1 - nwl
661 idiscu = nwu - iu
662*
663 IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
664 DO 80 je = 1, m
665 IF( w( je ).LE.wlu .AND. idiscl.GT.0 ) THEN
666 idiscl = idiscl - 1
667 ELSE IF( w( je ).GE.wul .AND. idiscu.GT.0 ) THEN
668 idiscu = idiscu - 1
669 ELSE
670 im = im + 1
671 w( im ) = w( je )
672 iblock( im ) = iblock( je )
673 END IF
674 80 CONTINUE
675 m = im
676 END IF
677 IF( idiscl.GT.0 .OR. idiscu.GT.0 ) THEN
678*
679* Code to deal with effects of bad arithmetic:
680* Some low eigenvalues to be discarded are not in (WL,WLU],
681* or high eigenvalues to be discarded are not in (WUL,WU]
682* so just kill off the smallest IDISCL/largest IDISCU
683* eigenvalues, by simply finding the smallest/largest
684* eigenvalue(s).
685*
686* (If N(w) is monotone non-decreasing, this should never
687* happen.)
688*
689 IF( idiscl.GT.0 ) THEN
690 wkill = wu
691 DO 100 jdisc = 1, idiscl
692 iw = 0
693 DO 90 je = 1, m
694 IF( iblock( je ).NE.0 .AND.
695 $ ( w( je ).LT.wkill .OR. iw.EQ.0 ) ) THEN
696 iw = je
697 wkill = w( je )
698 END IF
699 90 CONTINUE
700 iblock( iw ) = 0
701 100 CONTINUE
702 END IF
703 IF( idiscu.GT.0 ) THEN
704*
705 wkill = wl
706 DO 120 jdisc = 1, idiscu
707 iw = 0
708 DO 110 je = 1, m
709 IF( iblock( je ).NE.0 .AND.
710 $ ( w( je ).GT.wkill .OR. iw.EQ.0 ) ) THEN
711 iw = je
712 wkill = w( je )
713 END IF
714 110 CONTINUE
715 iblock( iw ) = 0
716 120 CONTINUE
717 END IF
718 im = 0
719 DO 130 je = 1, m
720 IF( iblock( je ).NE.0 ) THEN
721 im = im + 1
722 w( im ) = w( je )
723 iblock( im ) = iblock( je )
724 END IF
725 130 CONTINUE
726 m = im
727 END IF
728 IF( idiscl.LT.0 .OR. idiscu.LT.0 ) THEN
729 toofew = .true.
730 END IF
731 END IF
732*
733* If ORDER='B', do nothing -- the eigenvalues are already sorted
734* by block.
735* If ORDER='E', sort the eigenvalues from smallest to largest
736*
737 IF( iorder.EQ.1 .AND. nsplit.GT.1 ) THEN
738 DO 150 je = 1, m - 1
739 ie = 0
740 tmp1 = w( je )
741 DO 140 j = je + 1, m
742 IF( w( j ).LT.tmp1 ) THEN
743 ie = j
744 tmp1 = w( j )
745 END IF
746 140 CONTINUE
747*
748 IF( ie.NE.0 ) THEN
749 itmp1 = iblock( ie )
750 w( ie ) = w( je )
751 iblock( ie ) = iblock( je )
752 w( je ) = tmp1
753 iblock( je ) = itmp1
754 END IF
755 150 CONTINUE
756 END IF
757*
758 info = 0
759 IF( ncnvrg )
760 $ info = info + 1
761 IF( toofew )
762 $ info = info + 2
763 RETURN
764*
765* End of SSTEBZ
766*
slaebz
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 ...
Definition slaebz.f:319

◆ sstedc()

subroutine sstedc ( character compz,
integer n,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) work,
integer lwork,
integer, dimension( * ) iwork,
integer liwork,
integer info )

SSTEDC

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

Purpose:
!>
!> SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
!> symmetric tridiagonal matrix using the divide and conquer method.
!> The eigenvectors of a full or band real symmetric matrix can also be
!> found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
!> matrix to tridiagonal form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See SLAED3 for details.
!>
Parameters
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'I':  Compute eigenvectors of tridiagonal matrix also.
!>          = 'V':  Compute eigenvectors of original dense symmetric
!>                  matrix also.  On entry, Z contains the orthogonal
!>                  matrix used to reduce the original matrix to
!>                  tridiagonal form.
!>
[in]N
!>          N is INTEGER
!>          The dimension of the symmetric tridiagonal matrix.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the subdiagonal elements of the tridiagonal matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ,N)
!>          On entry, if COMPZ = 'V', then Z contains the orthogonal
!>          matrix used in the reduction to tridiagonal form.
!>          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
!>          orthonormal eigenvectors of the original symmetric matrix,
!>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!>          of the symmetric tridiagonal matrix.
!>          If  COMPZ = 'N', then Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1.
!>          If eigenvectors are desired, then LDZ >= max(1,N).
!>
[out]WORK
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
!>          If COMPZ = 'V' and N > 1 then LWORK must be at least
!>                         ( 1 + 3*N + 2*N*lg N + 4*N**2 ),
!>                         where lg( N ) = smallest integer k such
!>                         that 2**k >= N.
!>          If COMPZ = 'I' and N > 1 then LWORK must be at least
!>                         ( 1 + 4*N + N**2 ).
!>          Note that for COMPZ = 'I' or 'V', then if N is less than or
!>          equal to the minimum divide size, usually 25, then LWORK need
!>          only be max(1,2*(N-1)).
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!>
[in]LIWORK
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.
!>          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
!>          If COMPZ = 'V' and N > 1 then LIWORK must be at least
!>                         ( 6 + 6*N + 5*N*lg N ).
!>          If COMPZ = 'I' and N > 1 then LIWORK must be at least
!>                         ( 3 + 5*N ).
!>          Note that for COMPZ = 'I' or 'V', then if N is less than or
!>          equal to the minimum divide size, usually 25, then LIWORK
!>          need only be 1.
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates the optimal size of the IWORK array,
!>          returns this value as the first entry of the IWORK array, and
!>          no error message related to LIWORK is issued by XERBLA.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute an eigenvalue while
!>                working on the submatrix lying in rows and columns
!>                INFO/(N+1) through mod(INFO,N+1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Jeff Rutter, Computer Science Division, University of California at Berkeley, USA
Modified by Francoise Tisseur, University of Tennessee

Definition at line 186 of file sstedc.f.

188*
189* -- LAPACK computational routine --
190* -- LAPACK is a software package provided by Univ. of Tennessee, --
191* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
192*
193* .. Scalar Arguments ..
194 CHARACTER COMPZ
195 INTEGER INFO, LDZ, LIWORK, LWORK, N
196* ..
197* .. Array Arguments ..
198 INTEGER IWORK( * )
199 REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
200* ..
201*
202* =====================================================================
203*
204* .. Parameters ..
205 REAL ZERO, ONE, TWO
206 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
207* ..
208* .. Local Scalars ..
209 LOGICAL LQUERY
210 INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
211 $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
212 REAL EPS, ORGNRM, P, TINY
213* ..
214* .. External Functions ..
215 LOGICAL LSAME
216 INTEGER ILAENV
217 REAL SLAMCH, SLANST
218 EXTERNAL ilaenv, lsame, slamch, slanst
219* ..
220* .. External Subroutines ..
221 EXTERNAL sgemm, slacpy, slaed0, slascl, slaset, slasrt,
222 $ ssteqr, ssterf, sswap, xerbla
223* ..
224* .. Intrinsic Functions ..
225 INTRINSIC abs, int, log, max, mod, real, sqrt
226* ..
227* .. Executable Statements ..
228*
229* Test the input parameters.
230*
231 info = 0
232 lquery = ( lwork.EQ.-1 .OR. liwork.EQ.-1 )
233*
234 IF( lsame( compz, 'N' ) ) THEN
235 icompz = 0
236 ELSE IF( lsame( compz, 'V' ) ) THEN
237 icompz = 1
238 ELSE IF( lsame( compz, 'I' ) ) THEN
239 icompz = 2
240 ELSE
241 icompz = -1
242 END IF
243 IF( icompz.LT.0 ) THEN
244 info = -1
245 ELSE IF( n.LT.0 ) THEN
246 info = -2
247 ELSE IF( ( ldz.LT.1 ) .OR.
248 $ ( icompz.GT.0 .AND. ldz.LT.max( 1, n ) ) ) THEN
249 info = -6
250 END IF
251*
252 IF( info.EQ.0 ) THEN
253*
254* Compute the workspace requirements
255*
256 smlsiz = ilaenv( 9, 'SSTEDC', ' ', 0, 0, 0, 0 )
257 IF( n.LE.1 .OR. icompz.EQ.0 ) THEN
258 liwmin = 1
259 lwmin = 1
260 ELSE IF( n.LE.smlsiz ) THEN
261 liwmin = 1
262 lwmin = 2*( n - 1 )
263 ELSE
264 lgn = int( log( real( n ) )/log( two ) )
265 IF( 2**lgn.LT.n )
266 $ lgn = lgn + 1
267 IF( 2**lgn.LT.n )
268 $ lgn = lgn + 1
269 IF( icompz.EQ.1 ) THEN
270 lwmin = 1 + 3*n + 2*n*lgn + 4*n**2
271 liwmin = 6 + 6*n + 5*n*lgn
272 ELSE IF( icompz.EQ.2 ) THEN
273 lwmin = 1 + 4*n + n**2
274 liwmin = 3 + 5*n
275 END IF
276 END IF
277 work( 1 ) = lwmin
278 iwork( 1 ) = liwmin
279*
280 IF( lwork.LT.lwmin .AND. .NOT. lquery ) THEN
281 info = -8
282 ELSE IF( liwork.LT.liwmin .AND. .NOT. lquery ) THEN
283 info = -10
284 END IF
285 END IF
286*
287 IF( info.NE.0 ) THEN
288 CALL xerbla( 'SSTEDC', -info )
289 RETURN
290 ELSE IF (lquery) THEN
291 RETURN
292 END IF
293*
294* Quick return if possible
295*
296 IF( n.EQ.0 )
297 $ RETURN
298 IF( n.EQ.1 ) THEN
299 IF( icompz.NE.0 )
300 $ z( 1, 1 ) = one
301 RETURN
302 END IF
303*
304* If the following conditional clause is removed, then the routine
305* will use the Divide and Conquer routine to compute only the
306* eigenvalues, which requires (3N + 3N**2) real workspace and
307* (2 + 5N + 2N lg(N)) integer workspace.
308* Since on many architectures SSTERF is much faster than any other
309* algorithm for finding eigenvalues only, it is used here
310* as the default. If the conditional clause is removed, then
311* information on the size of workspace needs to be changed.
312*
313* If COMPZ = 'N', use SSTERF to compute the eigenvalues.
314*
315 IF( icompz.EQ.0 ) THEN
316 CALL ssterf( n, d, e, info )
317 GO TO 50
318 END IF
319*
320* If N is smaller than the minimum divide size (SMLSIZ+1), then
321* solve the problem with another solver.
322*
323 IF( n.LE.smlsiz ) THEN
324*
325 CALL ssteqr( compz, n, d, e, z, ldz, work, info )
326*
327 ELSE
328*
329* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
330* use.
331*
332 IF( icompz.EQ.1 ) THEN
333 storez = 1 + n*n
334 ELSE
335 storez = 1
336 END IF
337*
338 IF( icompz.EQ.2 ) THEN
339 CALL slaset( 'Full', n, n, zero, one, z, ldz )
340 END IF
341*
342* Scale.
343*
344 orgnrm = slanst( 'M', n, d, e )
345 IF( orgnrm.EQ.zero )
346 $ GO TO 50
347*
348 eps = slamch( 'Epsilon' )
349*
350 start = 1
351*
352* while ( START <= N )
353*
354 10 CONTINUE
355 IF( start.LE.n ) THEN
356*
357* Let FINISH be the position of the next subdiagonal entry
358* such that E( FINISH ) <= TINY or FINISH = N if no such
359* subdiagonal exists. The matrix identified by the elements
360* between START and FINISH constitutes an independent
361* sub-problem.
362*
363 finish = start
364 20 CONTINUE
365 IF( finish.LT.n ) THEN
366 tiny = eps*sqrt( abs( d( finish ) ) )*
367 $ sqrt( abs( d( finish+1 ) ) )
368 IF( abs( e( finish ) ).GT.tiny ) THEN
369 finish = finish + 1
370 GO TO 20
371 END IF
372 END IF
373*
374* (Sub) Problem determined. Compute its size and solve it.
375*
376 m = finish - start + 1
377 IF( m.EQ.1 ) THEN
378 start = finish + 1
379 GO TO 10
380 END IF
381 IF( m.GT.smlsiz ) THEN
382*
383* Scale.
384*
385 orgnrm = slanst( 'M', m, d( start ), e( start ) )
386 CALL slascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,
387 $ info )
388 CALL slascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),
389 $ m-1, info )
390*
391 IF( icompz.EQ.1 ) THEN
392 strtrw = 1
393 ELSE
394 strtrw = start
395 END IF
396 CALL slaed0( icompz, n, m, d( start ), e( start ),
397 $ z( strtrw, start ), ldz, work( 1 ), n,
398 $ work( storez ), iwork, info )
399 IF( info.NE.0 ) THEN
400 info = ( info / ( m+1 )+start-1 )*( n+1 ) +
401 $ mod( info, ( m+1 ) ) + start - 1
402 GO TO 50
403 END IF
404*
405* Scale back.
406*
407 CALL slascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,
408 $ info )
409*
410 ELSE
411 IF( icompz.EQ.1 ) THEN
412*
413* Since QR won't update a Z matrix which is larger than
414* the length of D, we must solve the sub-problem in a
415* workspace and then multiply back into Z.
416*
417 CALL ssteqr( 'I', m, d( start ), e( start ), work, m,
418 $ work( m*m+1 ), info )
419 CALL slacpy( 'A', n, m, z( 1, start ), ldz,
420 $ work( storez ), n )
421 CALL sgemm( 'N', 'N', n, m, m, one,
422 $ work( storez ), n, work, m, zero,
423 $ z( 1, start ), ldz )
424 ELSE IF( icompz.EQ.2 ) THEN
425 CALL ssteqr( 'I', m, d( start ), e( start ),
426 $ z( start, start ), ldz, work, info )
427 ELSE
428 CALL ssterf( m, d( start ), e( start ), info )
429 END IF
430 IF( info.NE.0 ) THEN
431 info = start*( n+1 ) + finish
432 GO TO 50
433 END IF
434 END IF
435*
436 start = finish + 1
437 GO TO 10
438 END IF
439*
440* endwhile
441*
442 IF( icompz.EQ.0 ) THEN
443*
444* Use Quick Sort
445*
446 CALL slasrt( 'I', n, d, info )
447*
448 ELSE
449*
450* Use Selection Sort to minimize swaps of eigenvectors
451*
452 DO 40 ii = 2, n
453 i = ii - 1
454 k = i
455 p = d( i )
456 DO 30 j = ii, n
457 IF( d( j ).LT.p ) THEN
458 k = j
459 p = d( j )
460 END IF
461 30 CONTINUE
462 IF( k.NE.i ) THEN
463 d( k ) = d( i )
464 d( i ) = p
465 CALL sswap( n, z( 1, i ), 1, z( 1, k ), 1 )
466 END IF
467 40 CONTINUE
468 END IF
469 END IF
470*
471 50 CONTINUE
472 work( 1 ) = lwmin
473 iwork( 1 ) = liwmin
474*
475 RETURN
476*
477* End of SSTEDC
478*
slaed0
subroutine slaed0(icompq, qsiz, n, d, e, q, ldq, qstore, ldqs, work, iwork, info)
SLAED0 used by SSTEDC. Computes all eigenvalues and corresponding eigenvectors of an unreduced symmet...
Definition slaed0.f:172
ssterf
subroutine ssterf(n, d, e, info)
SSTERF
Definition ssterf.f:86

◆ ssteqr()

subroutine ssteqr ( character compz,
integer n,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldz, * ) z,
integer ldz,
real, dimension( * ) work,
integer info )

SSTEQR

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

Purpose:
!>
!> SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
!> symmetric tridiagonal matrix using the implicit QL or QR method.
!> The eigenvectors of a full or band symmetric matrix can also be found
!> if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
!> tridiagonal form.
!>
Parameters
[in]COMPZ
!>          COMPZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only.
!>          = 'V':  Compute eigenvalues and eigenvectors of the original
!>                  symmetric matrix.  On entry, Z must contain the
!>                  orthogonal matrix used to reduce the original matrix
!>                  to tridiagonal form.
!>          = 'I':  Compute eigenvalues and eigenvectors of the
!>                  tridiagonal matrix.  Z is initialized to the identity
!>                  matrix.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!>
[in,out]Z
!>          Z is REAL array, dimension (LDZ, N)
!>          On entry, if  COMPZ = 'V', then Z contains the orthogonal
!>          matrix used in the reduction to tridiagonal form.
!>          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
!>          orthonormal eigenvectors of the original symmetric matrix,
!>          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
!>          of the symmetric tridiagonal matrix.
!>          If COMPZ = 'N', then Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          eigenvectors are desired, then  LDZ >= max(1,N).
!>
[out]WORK
!>          WORK is REAL array, dimension (max(1,2*N-2))
!>          If COMPZ = 'N', then WORK is not referenced.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm has failed to find all the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero; on exit, D
!>                and E contain the elements of a symmetric tridiagonal
!>                matrix which is orthogonally similar to the original
!>                matrix.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file ssteqr.f.

131*
132* -- LAPACK computational routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER COMPZ
138 INTEGER INFO, LDZ, N
139* ..
140* .. Array Arguments ..
141 REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 REAL ZERO, ONE, TWO, THREE
148 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
149 $ three = 3.0e0 )
150 INTEGER MAXIT
151 parameter( maxit = 30 )
152* ..
153* .. Local Scalars ..
154 INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
155 $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
156 $ NM1, NMAXIT
157 REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
158 $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 REAL SLAMCH, SLANST, SLAPY2
163 EXTERNAL lsame, slamch, slanst, slapy2
164* ..
165* .. External Subroutines ..
166 EXTERNAL slae2, slaev2, slartg, slascl, slaset, slasr,
167 $ slasrt, sswap, xerbla
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC abs, max, sign, sqrt
171* ..
172* .. Executable Statements ..
173*
174* Test the input parameters.
175*
176 info = 0
177*
178 IF( lsame( compz, 'N' ) ) THEN
179 icompz = 0
180 ELSE IF( lsame( compz, 'V' ) ) THEN
181 icompz = 1
182 ELSE IF( lsame( compz, 'I' ) ) THEN
183 icompz = 2
184 ELSE
185 icompz = -1
186 END IF
187 IF( icompz.LT.0 ) THEN
188 info = -1
189 ELSE IF( n.LT.0 ) THEN
190 info = -2
191 ELSE IF( ( ldz.LT.1 ) .OR. ( icompz.GT.0 .AND. ldz.LT.max( 1,
192 $ n ) ) ) THEN
193 info = -6
194 END IF
195 IF( info.NE.0 ) THEN
196 CALL xerbla( 'SSTEQR', -info )
197 RETURN
198 END IF
199*
200* Quick return if possible
201*
202 IF( n.EQ.0 )
203 $ RETURN
204*
205 IF( n.EQ.1 ) THEN
206 IF( icompz.EQ.2 )
207 $ z( 1, 1 ) = one
208 RETURN
209 END IF
210*
211* Determine the unit roundoff and over/underflow thresholds.
212*
213 eps = slamch( 'E' )
214 eps2 = eps**2
215 safmin = slamch( 'S' )
216 safmax = one / safmin
217 ssfmax = sqrt( safmax ) / three
218 ssfmin = sqrt( safmin ) / eps2
219*
220* Compute the eigenvalues and eigenvectors of the tridiagonal
221* matrix.
222*
223 IF( icompz.EQ.2 )
224 $ CALL slaset( 'Full', n, n, zero, one, z, ldz )
225*
226 nmaxit = n*maxit
227 jtot = 0
228*
229* Determine where the matrix splits and choose QL or QR iteration
230* for each block, according to whether top or bottom diagonal
231* element is smaller.
232*
233 l1 = 1
234 nm1 = n - 1
235*
236 10 CONTINUE
237 IF( l1.GT.n )
238 $ GO TO 160
239 IF( l1.GT.1 )
240 $ e( l1-1 ) = zero
241 IF( l1.LE.nm1 ) THEN
242 DO 20 m = l1, nm1
243 tst = abs( e( m ) )
244 IF( tst.EQ.zero )
245 $ GO TO 30
246 IF( tst.LE.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+
247 $ 1 ) ) ) )*eps ) THEN
248 e( m ) = zero
249 GO TO 30
250 END IF
251 20 CONTINUE
252 END IF
253 m = n
254*
255 30 CONTINUE
256 l = l1
257 lsv = l
258 lend = m
259 lendsv = lend
260 l1 = m + 1
261 IF( lend.EQ.l )
262 $ GO TO 10
263*
264* Scale submatrix in rows and columns L to LEND
265*
266 anorm = slanst( 'M', lend-l+1, d( l ), e( l ) )
267 iscale = 0
268 IF( anorm.EQ.zero )
269 $ GO TO 10
270 IF( anorm.GT.ssfmax ) THEN
271 iscale = 1
272 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
273 $ info )
274 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
275 $ info )
276 ELSE IF( anorm.LT.ssfmin ) THEN
277 iscale = 2
278 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
279 $ info )
280 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
281 $ info )
282 END IF
283*
284* Choose between QL and QR iteration
285*
286 IF( abs( d( lend ) ).LT.abs( d( l ) ) ) THEN
287 lend = lsv
288 l = lendsv
289 END IF
290*
291 IF( lend.GT.l ) THEN
292*
293* QL Iteration
294*
295* Look for small subdiagonal element.
296*
297 40 CONTINUE
298 IF( l.NE.lend ) THEN
299 lendm1 = lend - 1
300 DO 50 m = l, lendm1
301 tst = abs( e( m ) )**2
302 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+
303 $ safmin )GO TO 60
304 50 CONTINUE
305 END IF
306*
307 m = lend
308*
309 60 CONTINUE
310 IF( m.LT.lend )
311 $ e( m ) = zero
312 p = d( l )
313 IF( m.EQ.l )
314 $ GO TO 80
315*
316* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
317* to compute its eigensystem.
318*
319 IF( m.EQ.l+1 ) THEN
320 IF( icompz.GT.0 ) THEN
321 CALL slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s )
322 work( l ) = c
323 work( n-1+l ) = s
324 CALL slasr( 'R', 'V', 'B', n, 2, work( l ),
325 $ work( n-1+l ), z( 1, l ), ldz )
326 ELSE
327 CALL slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 )
328 END IF
329 d( l ) = rt1
330 d( l+1 ) = rt2
331 e( l ) = zero
332 l = l + 2
333 IF( l.LE.lend )
334 $ GO TO 40
335 GO TO 140
336 END IF
337*
338 IF( jtot.EQ.nmaxit )
339 $ GO TO 140
340 jtot = jtot + 1
341*
342* Form shift.
343*
344 g = ( d( l+1 )-p ) / ( two*e( l ) )
345 r = slapy2( g, one )
346 g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) )
347*
348 s = one
349 c = one
350 p = zero
351*
352* Inner loop
353*
354 mm1 = m - 1
355 DO 70 i = mm1, l, -1
356 f = s*e( i )
357 b = c*e( i )
358 CALL slartg( g, f, c, s, r )
359 IF( i.NE.m-1 )
360 $ e( i+1 ) = r
361 g = d( i+1 ) - p
362 r = ( d( i )-g )*s + two*c*b
363 p = s*r
364 d( i+1 ) = g + p
365 g = c*r - b
366*
367* If eigenvectors are desired, then save rotations.
368*
369 IF( icompz.GT.0 ) THEN
370 work( i ) = c
371 work( n-1+i ) = -s
372 END IF
373*
374 70 CONTINUE
375*
376* If eigenvectors are desired, then apply saved rotations.
377*
378 IF( icompz.GT.0 ) THEN
379 mm = m - l + 1
380 CALL slasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),
381 $ z( 1, l ), ldz )
382 END IF
383*
384 d( l ) = d( l ) - p
385 e( l ) = g
386 GO TO 40
387*
388* Eigenvalue found.
389*
390 80 CONTINUE
391 d( l ) = p
392*
393 l = l + 1
394 IF( l.LE.lend )
395 $ GO TO 40
396 GO TO 140
397*
398 ELSE
399*
400* QR Iteration
401*
402* Look for small superdiagonal element.
403*
404 90 CONTINUE
405 IF( l.NE.lend ) THEN
406 lendp1 = lend + 1
407 DO 100 m = l, lendp1, -1
408 tst = abs( e( m-1 ) )**2
409 IF( tst.LE.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+
410 $ safmin )GO TO 110
411 100 CONTINUE
412 END IF
413*
414 m = lend
415*
416 110 CONTINUE
417 IF( m.GT.lend )
418 $ e( m-1 ) = zero
419 p = d( l )
420 IF( m.EQ.l )
421 $ GO TO 130
422*
423* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
424* to compute its eigensystem.
425*
426 IF( m.EQ.l-1 ) THEN
427 IF( icompz.GT.0 ) THEN
428 CALL slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s )
429 work( m ) = c
430 work( n-1+m ) = s
431 CALL slasr( 'R', 'V', 'F', n, 2, work( m ),
432 $ work( n-1+m ), z( 1, l-1 ), ldz )
433 ELSE
434 CALL slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 )
435 END IF
436 d( l-1 ) = rt1
437 d( l ) = rt2
438 e( l-1 ) = zero
439 l = l - 2
440 IF( l.GE.lend )
441 $ GO TO 90
442 GO TO 140
443 END IF
444*
445 IF( jtot.EQ.nmaxit )
446 $ GO TO 140
447 jtot = jtot + 1
448*
449* Form shift.
450*
451 g = ( d( l-1 )-p ) / ( two*e( l-1 ) )
452 r = slapy2( g, one )
453 g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) )
454*
455 s = one
456 c = one
457 p = zero
458*
459* Inner loop
460*
461 lm1 = l - 1
462 DO 120 i = m, lm1
463 f = s*e( i )
464 b = c*e( i )
465 CALL slartg( g, f, c, s, r )
466 IF( i.NE.m )
467 $ e( i-1 ) = r
468 g = d( i ) - p
469 r = ( d( i+1 )-g )*s + two*c*b
470 p = s*r
471 d( i ) = g + p
472 g = c*r - b
473*
474* If eigenvectors are desired, then save rotations.
475*
476 IF( icompz.GT.0 ) THEN
477 work( i ) = c
478 work( n-1+i ) = s
479 END IF
480*
481 120 CONTINUE
482*
483* If eigenvectors are desired, then apply saved rotations.
484*
485 IF( icompz.GT.0 ) THEN
486 mm = l - m + 1
487 CALL slasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),
488 $ z( 1, m ), ldz )
489 END IF
490*
491 d( l ) = d( l ) - p
492 e( lm1 ) = g
493 GO TO 90
494*
495* Eigenvalue found.
496*
497 130 CONTINUE
498 d( l ) = p
499*
500 l = l - 1
501 IF( l.GE.lend )
502 $ GO TO 90
503 GO TO 140
504*
505 END IF
506*
507* Undo scaling if necessary
508*
509 140 CONTINUE
510 IF( iscale.EQ.1 ) THEN
511 CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
512 $ d( lsv ), n, info )
513 CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),
514 $ n, info )
515 ELSE IF( iscale.EQ.2 ) THEN
516 CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
517 $ d( lsv ), n, info )
518 CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),
519 $ n, info )
520 END IF
521*
522* Check for no convergence to an eigenvalue after a total
523* of N*MAXIT iterations.
524*
525 IF( jtot.LT.nmaxit )
526 $ GO TO 10
527 DO 150 i = 1, n - 1
528 IF( e( i ).NE.zero )
529 $ info = info + 1
530 150 CONTINUE
531 GO TO 190
532*
533* Order eigenvalues and eigenvectors.
534*
535 160 CONTINUE
536 IF( icompz.EQ.0 ) THEN
537*
538* Use Quick Sort
539*
540 CALL slasrt( 'I', n, d, info )
541*
542 ELSE
543*
544* Use Selection Sort to minimize swaps of eigenvectors
545*
546 DO 180 ii = 2, n
547 i = ii - 1
548 k = i
549 p = d( i )
550 DO 170 j = ii, n
551 IF( d( j ).LT.p ) THEN
552 k = j
553 p = d( j )
554 END IF
555 170 CONTINUE
556 IF( k.NE.i ) THEN
557 d( k ) = d( i )
558 d( i ) = p
559 CALL sswap( n, z( 1, i ), 1, z( 1, k ), 1 )
560 END IF
561 180 CONTINUE
562 END IF
563*
564 190 CONTINUE
565 RETURN
566*
567* End of SSTEQR
568*
slae2
subroutine slae2(a, b, c, rt1, rt2)
SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix.
Definition slae2.f:102
slaev2
subroutine slaev2(a, b, c, rt1, rt2, cs1, sn1)
SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition slaev2.f:120

◆ ssterf()

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

SSTERF

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

Purpose:
!>
!> SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
!> using the Pal-Walker-Kahan variant of the QL or QR algorithm.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in,out]D
!>          D is REAL array, dimension (N)
!>          On entry, the n diagonal elements of the tridiagonal matrix.
!>          On exit, if INFO = 0, the eigenvalues in ascending order.
!>
[in,out]E
!>          E is REAL array, dimension (N-1)
!>          On entry, the (n-1) subdiagonal elements of the tridiagonal
!>          matrix.
!>          On exit, E has been destroyed.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  the algorithm failed to find all of the eigenvalues in
!>                a total of 30*N iterations; if INFO = i, then i
!>                elements of E have not converged to zero.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 85 of file ssterf.f.

86*
87* -- LAPACK computational routine --
88* -- LAPACK is a software package provided by Univ. of Tennessee, --
89* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
90*
91* .. Scalar Arguments ..
92 INTEGER INFO, N
93* ..
94* .. Array Arguments ..
95 REAL D( * ), E( * )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 REAL ZERO, ONE, TWO, THREE
102 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
103 $ three = 3.0e0 )
104 INTEGER MAXIT
105 parameter( maxit = 30 )
106* ..
107* .. Local Scalars ..
108 INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
109 $ NMAXIT
110 REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
111 $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
112 $ SIGMA, SSFMAX, SSFMIN
113* ..
114* .. External Functions ..
115 REAL SLAMCH, SLANST, SLAPY2
116 EXTERNAL slamch, slanst, slapy2
117* ..
118* .. External Subroutines ..
119 EXTERNAL slae2, slascl, slasrt, xerbla
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Test the input parameters.
127*
128 info = 0
129*
130* Quick return if possible
131*
132 IF( n.LT.0 ) THEN
133 info = -1
134 CALL xerbla( 'SSTERF', -info )
135 RETURN
136 END IF
137 IF( n.LE.1 )
138 $ RETURN
139*
140* Determine the unit roundoff for this environment.
141*
142 eps = slamch( 'E' )
143 eps2 = eps**2
144 safmin = slamch( 'S' )
145 safmax = one / safmin
146 ssfmax = sqrt( safmax ) / three
147 ssfmin = sqrt( safmin ) / eps2
148*
149* Compute the eigenvalues of the tridiagonal matrix.
150*
151 nmaxit = n*maxit
152 sigma = zero
153 jtot = 0
154*
155* Determine where the matrix splits and choose QL or QR iteration
156* for each block, according to whether top or bottom diagonal
157* element is smaller.
158*
159 l1 = 1
160*
161 10 CONTINUE
162 IF( l1.GT.n )
163 $ GO TO 170
164 IF( l1.GT.1 )
165 $ e( l1-1 ) = zero
166 DO 20 m = l1, n - 1
167 IF( abs( e( m ) ).LE.( sqrt( abs( d( m ) ) )*
168 $ sqrt( abs( d( m+1 ) ) ) )*eps ) THEN
169 e( m ) = zero
170 GO TO 30
171 END IF
172 20 CONTINUE
173 m = n
174*
175 30 CONTINUE
176 l = l1
177 lsv = l
178 lend = m
179 lendsv = lend
180 l1 = m + 1
181 IF( lend.EQ.l )
182 $ GO TO 10
183*
184* Scale submatrix in rows and columns L to LEND
185*
186 anorm = slanst( 'M', lend-l+1, d( l ), e( l ) )
187 iscale = 0
188 IF( anorm.EQ.zero )
189 $ GO TO 10
190 IF( anorm.GT.ssfmax ) THEN
191 iscale = 1
192 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,
193 $ info )
194 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,
195 $ info )
196 ELSE IF( anorm.LT.ssfmin ) THEN
197 iscale = 2
198 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n,
199 $ info )
200 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n,
201 $ info )
202 END IF
203*
204 DO 40 i = l, lend - 1
205 e( i ) = e( i )**2
206 40 CONTINUE
207*
208* Choose between QL and QR iteration
209*
210 IF( abs( d( lend ) ).LT.abs( d( l ) ) ) THEN
211 lend = lsv
212 l = lendsv
213 END IF
214*
215 IF( lend.GE.l ) THEN
216*
217* QL Iteration
218*
219* Look for small subdiagonal element.
220*
221 50 CONTINUE
222 IF( l.NE.lend ) THEN
223 DO 60 m = l, lend - 1
224 IF( abs( e( m ) ).LE.eps2*abs( d( m )*d( m+1 ) ) )
225 $ GO TO 70
226 60 CONTINUE
227 END IF
228 m = lend
229*
230 70 CONTINUE
231 IF( m.LT.lend )
232 $ e( m ) = zero
233 p = d( l )
234 IF( m.EQ.l )
235 $ GO TO 90
236*
237* If remaining matrix is 2 by 2, use SLAE2 to compute its
238* eigenvalues.
239*
240 IF( m.EQ.l+1 ) THEN
241 rte = sqrt( e( l ) )
242 CALL slae2( d( l ), rte, d( l+1 ), rt1, rt2 )
243 d( l ) = rt1
244 d( l+1 ) = rt2
245 e( l ) = zero
246 l = l + 2
247 IF( l.LE.lend )
248 $ GO TO 50
249 GO TO 150
250 END IF
251*
252 IF( jtot.EQ.nmaxit )
253 $ GO TO 150
254 jtot = jtot + 1
255*
256* Form shift.
257*
258 rte = sqrt( e( l ) )
259 sigma = ( d( l+1 )-p ) / ( two*rte )
260 r = slapy2( sigma, one )
261 sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
262*
263 c = one
264 s = zero
265 gamma = d( m ) - sigma
266 p = gamma*gamma
267*
268* Inner loop
269*
270 DO 80 i = m - 1, l, -1
271 bb = e( i )
272 r = p + bb
273 IF( i.NE.m-1 )
274 $ e( i+1 ) = s*r
275 oldc = c
276 c = p / r
277 s = bb / r
278 oldgam = gamma
279 alpha = d( i )
280 gamma = c*( alpha-sigma ) - s*oldgam
281 d( i+1 ) = oldgam + ( alpha-gamma )
282 IF( c.NE.zero ) THEN
283 p = ( gamma*gamma ) / c
284 ELSE
285 p = oldc*bb
286 END IF
287 80 CONTINUE
288*
289 e( l ) = s*p
290 d( l ) = sigma + gamma
291 GO TO 50
292*
293* Eigenvalue found.
294*
295 90 CONTINUE
296 d( l ) = p
297*
298 l = l + 1
299 IF( l.LE.lend )
300 $ GO TO 50
301 GO TO 150
302*
303 ELSE
304*
305* QR Iteration
306*
307* Look for small superdiagonal element.
308*
309 100 CONTINUE
310 DO 110 m = l, lend + 1, -1
311 IF( abs( e( m-1 ) ).LE.eps2*abs( d( m )*d( m-1 ) ) )
312 $ GO TO 120
313 110 CONTINUE
314 m = lend
315*
316 120 CONTINUE
317 IF( m.GT.lend )
318 $ e( m-1 ) = zero
319 p = d( l )
320 IF( m.EQ.l )
321 $ GO TO 140
322*
323* If remaining matrix is 2 by 2, use SLAE2 to compute its
324* eigenvalues.
325*
326 IF( m.EQ.l-1 ) THEN
327 rte = sqrt( e( l-1 ) )
328 CALL slae2( d( l ), rte, d( l-1 ), rt1, rt2 )
329 d( l ) = rt1
330 d( l-1 ) = rt2
331 e( l-1 ) = zero
332 l = l - 2
333 IF( l.GE.lend )
334 $ GO TO 100
335 GO TO 150
336 END IF
337*
338 IF( jtot.EQ.nmaxit )
339 $ GO TO 150
340 jtot = jtot + 1
341*
342* Form shift.
343*
344 rte = sqrt( e( l-1 ) )
345 sigma = ( d( l-1 )-p ) / ( two*rte )
346 r = slapy2( sigma, one )
347 sigma = p - ( rte / ( sigma+sign( r, sigma ) ) )
348*
349 c = one
350 s = zero
351 gamma = d( m ) - sigma
352 p = gamma*gamma
353*
354* Inner loop
355*
356 DO 130 i = m, l - 1
357 bb = e( i )
358 r = p + bb
359 IF( i.NE.m )
360 $ e( i-1 ) = s*r
361 oldc = c
362 c = p / r
363 s = bb / r
364 oldgam = gamma
365 alpha = d( i+1 )
366 gamma = c*( alpha-sigma ) - s*oldgam
367 d( i ) = oldgam + ( alpha-gamma )
368 IF( c.NE.zero ) THEN
369 p = ( gamma*gamma ) / c
370 ELSE
371 p = oldc*bb
372 END IF
373 130 CONTINUE
374*
375 e( l-1 ) = s*p
376 d( l ) = sigma + gamma
377 GO TO 100
378*
379* Eigenvalue found.
380*
381 140 CONTINUE
382 d( l ) = p
383*
384 l = l - 1
385 IF( l.GE.lend )
386 $ GO TO 100
387 GO TO 150
388*
389 END IF
390*
391* Undo scaling if necessary
392*
393 150 CONTINUE
394 IF( iscale.EQ.1 )
395 $ CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,
396 $ d( lsv ), n, info )
397 IF( iscale.EQ.2 )
398 $ CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,
399 $ d( lsv ), n, info )
400*
401* Check for no convergence to an eigenvalue after a total
402* of N*MAXIT iterations.
403*
404 IF( jtot.LT.nmaxit )
405 $ GO TO 10
406 DO 160 i = 1, n - 1
407 IF( e( i ).NE.zero )
408 $ info = info + 1
409 160 CONTINUE
410 GO TO 180
411*
412* Sort eigenvalues in increasing order.
413*
414 170 CONTINUE
415 CALL slasrt( 'I', n, d, info )
416*
417 180 CONTINUE
418 RETURN
419*
420* End of SSTERF
421*