OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
double
LAPACK » Other Auxiliary Routines

Functions

subroutine dlahrd (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 DLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below the k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
subroutine dlabrd (m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
 DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
subroutine dlacn2 (n, v, x, isgn, est, kase, isave)
 DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine dlacon (n, v, x, isgn, est, kase)
 DLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine dladiv (a, b, c, d, p, q)
 DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
subroutine dladiv1 (a, b, c, d, p, q)
double precision function dladiv2 (a, b, c, d, r, t)
subroutine dlaein (rightv, noinit, n, h, ldh, wr, wi, vr, vi, b, ldb, work, eps3, smlnum, bignum, info)
 DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration.
subroutine dlaexc (wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
 DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation.
subroutine dlag2 (a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
 DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow.
subroutine dlag2s (m, n, a, lda, sa, ldsa, info)
 DLAG2S converts a double precision matrix to a single precision matrix.
subroutine dlags2 (upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
 DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel.
subroutine dlagtm (trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
 DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1.
subroutine dlagv2 (a, lda, b, ldb, alphar, alphai, beta, csl, snl, csr, snr)
 DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular.
subroutine dlahqr (wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, info)
 DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
subroutine dlahr2 (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
subroutine dlaic1 (job, j, x, sest, w, gamma, sestpr, s, c)
 DLAIC1 applies one step of incremental condition estimation.
subroutine dlaln2 (ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
 DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
double precision function dlangt (norm, n, dl, d, du)
 DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix.
double precision function dlanhs (norm, n, a, lda, work)
 DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.
double precision function dlansb (norm, uplo, n, k, ab, ldab, work)
 DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.
double precision function dlansp (norm, uplo, n, ap, work)
 DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
double precision function dlantb (norm, uplo, diag, n, k, ab, ldab, work)
 DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
double precision function dlantp (norm, uplo, diag, n, ap, work)
 DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.
double precision function dlantr (norm, uplo, diag, m, n, a, lda, work)
 DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
subroutine dlanv2 (a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn)
 DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
subroutine dlapll (n, x, incx, y, incy, ssmin)
 DLAPLL measures the linear dependence of two vectors.
subroutine dlapmr (forwrd, m, n, x, ldx, k)
 DLAPMR rearranges rows of a matrix as specified by a permutation vector.
subroutine dlapmt (forwrd, m, n, x, ldx, k)
 DLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine dlaqp2 (m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
 DLAQP2 computes a QR factorization with column pivoting of the matrix block.
subroutine dlaqps (m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
 DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.
subroutine dlaqr0 (wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, work, lwork, info)
 DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine dlaqr1 (n, h, ldh, sr1, si1, sr2, si2, v)
 DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.
subroutine dlaqr2 (wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sr, si, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
 DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
subroutine dlaqr3 (wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sr, si, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
 DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
subroutine dlaqr4 (wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, work, lwork, info)
 DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine dlaqr5 (wantt, wantz, kacc22, n, ktop, kbot, nshfts, sr, si, h, ldh, iloz, ihiz, z, ldz, v, ldv, u, ldu, nv, wv, ldwv, nh, wh, ldwh)
 DLAQR5 performs a single small-bulge multi-shift QR sweep.
subroutine dlaqsb (uplo, n, kd, ab, ldab, s, scond, amax, equed)
 DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ.
subroutine dlaqsp (uplo, n, ap, s, scond, amax, equed)
 DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ.
subroutine dlaqtr (ltran, lreal, n, t, ldt, b, w, scale, x, work, info)
 DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of special form, in real arithmetic.
subroutine dlar1v (n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
 DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI.
subroutine dlar2v (n, x, y, z, incx, c, s, incc)
 DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.
subroutine dlarf (side, m, n, v, incv, tau, c, ldc, work)
 DLARF applies an elementary reflector to a general rectangular matrix.
subroutine dlarfb (side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
 DLARFB applies a block reflector or its transpose to a general rectangular matrix.
subroutine dlarfb_gett (ident, m, n, k, t, ldt, a, lda, b, ldb, work, ldwork)
 DLARFB_GETT
subroutine dlarfg (n, alpha, x, incx, tau)
 DLARFG generates an elementary reflector (Householder matrix).
subroutine dlarfgp (n, alpha, x, incx, tau)
 DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
subroutine dlarft (direct, storev, n, k, v, ldv, tau, t, ldt)
 DLARFT forms the triangular factor T of a block reflector H = I - vtvH
subroutine dlarfx (side, m, n, v, tau, c, ldc, work)
 DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.
subroutine dlarfy (uplo, n, v, incv, tau, c, ldc, work)
 DLARFY
subroutine dlargv (n, x, incx, y, incy, c, incc)
 DLARGV generates a vector of plane rotations with real cosines and real sines.
subroutine dlarrv (n, vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, z, ldz, isuppz, work, iwork, info)
 DLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT.
subroutine dlartv (n, x, incx, y, incy, c, s, incc)
 DLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair of vectors.
subroutine dlaswp (n, a, lda, k1, k2, ipiv, incx)
 DLASWP performs a series of row interchanges on a general rectangular matrix.
subroutine dlat2s (uplo, n, a, lda, sa, ldsa, info)
 DLAT2S converts a double-precision triangular matrix to a single-precision triangular matrix.
subroutine dlatbs (uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
 DLATBS solves a triangular banded system of equations.
subroutine dlatdf (ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv)
 DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
subroutine dlatps (uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
 DLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine dlatrd (uplo, n, nb, a, lda, e, tau, w, ldw)
 DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.
subroutine dlatrs (uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
 DLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
subroutine dlauu2 (uplo, n, a, lda, info)
 DLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).
subroutine dlauum (uplo, n, a, lda, info)
 DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
subroutine drscl (n, sa, sx, incx)
 DRSCL multiplies a vector by the reciprocal of a real scalar.
subroutine dtprfb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
 DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks.
subroutine slatrd (uplo, n, nb, a, lda, e, tau, w, ldw)
 SLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.

Detailed Description

This is the group of double other auxiliary routines

Function Documentation

◆ dlabrd()

subroutine dlabrd ( integer m,
integer n,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( * ) tauq,
double precision, dimension( * ) taup,
double precision, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( ldy, * ) y,
integer ldy )

DLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.

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

Purpose:
!>
!> DLABRD reduces the first NB rows and columns of a real general
!> m by n matrix A to upper or lower bidiagonal form by an orthogonal
!> transformation Q**T * A * P, and returns the matrices X and Y which
!> are needed to apply the transformation to the unreduced part of A.
!>
!> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
!> bidiagonal form.
!>
!> This is an auxiliary routine called by DGEBRD
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix A.
!>
[in]NB
!>          NB is INTEGER
!>          The number of leading rows and columns of A to be reduced.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the m by n general matrix to be reduced.
!>          On exit, the first NB rows and columns of the matrix are
!>          overwritten; the rest of the array is unchanged.
!>          If m >= n, elements on and below the diagonal in the first NB
!>            columns, with the array TAUQ, represent the orthogonal
!>            matrix Q as a product of elementary reflectors; and
!>            elements above the diagonal in the first NB rows, with the
!>            array TAUP, represent the orthogonal matrix P as a product
!>            of elementary reflectors.
!>          If m < n, elements below the diagonal in the first NB
!>            columns, with the array TAUQ, represent the orthogonal
!>            matrix Q as a product of elementary reflectors, and
!>            elements on and above the diagonal in the first NB rows,
!>            with the array TAUP, represent the orthogonal matrix P as
!>            a product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (NB)
!>          The diagonal elements of the first NB rows and columns of
!>          the reduced matrix.  D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (NB)
!>          The off-diagonal elements of the first NB rows and columns of
!>          the reduced matrix.
!>
[out]TAUQ
!>          TAUQ is DOUBLE PRECISION array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is DOUBLE PRECISION array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the orthogonal matrix P. See Further Details.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (LDX,NB)
!>          The m-by-nb matrix X required to update the unreduced part
!>          of A.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X. LDX >= max(1,M).
!>
[out]Y
!>          Y is DOUBLE PRECISION array, dimension (LDY,NB)
!>          The n-by-nb matrix Y required to update the unreduced part
!>          of A.
!>
[in]LDY
!>          LDY is INTEGER
!>          The leading dimension of the array Y. LDY >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrices Q and P are represented as products of elementary
!>  reflectors:
!>
!>     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
!>
!>  Each H(i) and G(i) has the form:
!>
!>     H(i) = I - tauq * v * v**T  and G(i) = I - taup * u * u**T
!>
!>  where tauq and taup are real scalars, and v and u are real vectors.
!>
!>  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
!>  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
!>  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
!>  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
!>  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
!>
!>  The elements of the vectors v and u together form the m-by-nb matrix
!>  V and the nb-by-n matrix U**T which are needed, with X and Y, to apply
!>  the transformation to the unreduced part of the matrix, using a block
!>  update of the form:  A := A - V*Y**T - X*U**T.
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with nb = 2:
!>
!>  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
!>
!>    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
!>    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
!>    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
!>    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
!>    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
!>    (  v1  v2  a   a   a  )
!>
!>  where a denotes an element of the original matrix which is unchanged,
!>  vi denotes an element of the vector defining H(i), and ui an element
!>  of the vector defining G(i).
!>

Definition at line 208 of file dlabrd.f.

210*
211* -- LAPACK auxiliary routine --
212* -- LAPACK is a software package provided by Univ. of Tennessee, --
213* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
214*
215* .. Scalar Arguments ..
216 INTEGER LDA, LDX, LDY, M, N, NB
217* ..
218* .. Array Arguments ..
219 DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
220 $ TAUQ( * ), X( LDX, * ), Y( LDY, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 DOUBLE PRECISION ZERO, ONE
227 parameter( zero = 0.0d0, one = 1.0d0 )
228* ..
229* .. Local Scalars ..
230 INTEGER I
231* ..
232* .. External Subroutines ..
233 EXTERNAL dgemv, dlarfg, dscal
234* ..
235* .. Intrinsic Functions ..
236 INTRINSIC min
237* ..
238* .. Executable Statements ..
239*
240* Quick return if possible
241*
242 IF( m.LE.0 .OR. n.LE.0 )
243 $ RETURN
244*
245 IF( m.GE.n ) THEN
246*
247* Reduce to upper bidiagonal form
248*
249 DO 10 i = 1, nb
250*
251* Update A(i:m,i)
252*
253 CALL dgemv( 'No transpose', m-i+1, i-1, -one, a( i, 1 ),
254 $ lda, y( i, 1 ), ldy, one, a( i, i ), 1 )
255 CALL dgemv( 'No transpose', m-i+1, i-1, -one, x( i, 1 ),
256 $ ldx, a( 1, i ), 1, one, a( i, i ), 1 )
257*
258* Generate reflection Q(i) to annihilate A(i+1:m,i)
259*
260 CALL dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
261 $ tauq( i ) )
262 d( i ) = a( i, i )
263 IF( i.LT.n ) THEN
264 a( i, i ) = one
265*
266* Compute Y(i+1:n,i)
267*
268 CALL dgemv( 'Transpose', m-i+1, n-i, one, a( i, i+1 ),
269 $ lda, a( i, i ), 1, zero, y( i+1, i ), 1 )
270 CALL dgemv( 'Transpose', m-i+1, i-1, one, a( i, 1 ), lda,
271 $ a( i, i ), 1, zero, y( 1, i ), 1 )
272 CALL dgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
273 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
274 CALL dgemv( 'Transpose', m-i+1, i-1, one, x( i, 1 ), ldx,
275 $ a( i, i ), 1, zero, y( 1, i ), 1 )
276 CALL dgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ),
277 $ lda, y( 1, i ), 1, one, y( i+1, i ), 1 )
278 CALL dscal( n-i, tauq( i ), y( i+1, i ), 1 )
279*
280* Update A(i,i+1:n)
281*
282 CALL dgemv( 'No transpose', n-i, i, -one, y( i+1, 1 ),
283 $ ldy, a( i, 1 ), lda, one, a( i, i+1 ), lda )
284 CALL dgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ),
285 $ lda, x( i, 1 ), ldx, one, a( i, i+1 ), lda )
286*
287* Generate reflection P(i) to annihilate A(i,i+2:n)
288*
289 CALL dlarfg( n-i, a( i, i+1 ), a( i, min( i+2, n ) ),
290 $ lda, taup( i ) )
291 e( i ) = a( i, i+1 )
292 a( i, i+1 ) = one
293*
294* Compute X(i+1:m,i)
295*
296 CALL dgemv( 'No transpose', m-i, n-i, one, a( i+1, i+1 ),
297 $ lda, a( i, i+1 ), lda, zero, x( i+1, i ), 1 )
298 CALL dgemv( 'Transpose', n-i, i, one, y( i+1, 1 ), ldy,
299 $ a( i, i+1 ), lda, zero, x( 1, i ), 1 )
300 CALL dgemv( 'No transpose', m-i, i, -one, a( i+1, 1 ),
301 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
302 CALL dgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
303 $ lda, a( i, i+1 ), lda, zero, x( 1, i ), 1 )
304 CALL dgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
305 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
306 CALL dscal( m-i, taup( i ), x( i+1, i ), 1 )
307 END IF
308 10 CONTINUE
309 ELSE
310*
311* Reduce to lower bidiagonal form
312*
313 DO 20 i = 1, nb
314*
315* Update A(i,i:n)
316*
317 CALL dgemv( 'No transpose', n-i+1, i-1, -one, y( i, 1 ),
318 $ ldy, a( i, 1 ), lda, one, a( i, i ), lda )
319 CALL dgemv( 'Transpose', i-1, n-i+1, -one, a( 1, i ), lda,
320 $ x( i, 1 ), ldx, one, a( i, i ), lda )
321*
322* Generate reflection P(i) to annihilate A(i,i+1:n)
323*
324 CALL dlarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
325 $ taup( i ) )
326 d( i ) = a( i, i )
327 IF( i.LT.m ) THEN
328 a( i, i ) = one
329*
330* Compute X(i+1:m,i)
331*
332 CALL dgemv( 'No transpose', m-i, n-i+1, one, a( i+1, i ),
333 $ lda, a( i, i ), lda, zero, x( i+1, i ), 1 )
334 CALL dgemv( 'Transpose', n-i+1, i-1, one, y( i, 1 ), ldy,
335 $ a( i, i ), lda, zero, x( 1, i ), 1 )
336 CALL dgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
337 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
338 CALL dgemv( 'No transpose', i-1, n-i+1, one, a( 1, i ),
339 $ lda, a( i, i ), lda, zero, x( 1, i ), 1 )
340 CALL dgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
341 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
342 CALL dscal( m-i, taup( i ), x( i+1, i ), 1 )
343*
344* Update A(i+1:m,i)
345*
346 CALL dgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
347 $ lda, y( i, 1 ), ldy, one, a( i+1, i ), 1 )
348 CALL dgemv( 'No transpose', m-i, i, -one, x( i+1, 1 ),
349 $ ldx, a( 1, i ), 1, one, a( i+1, i ), 1 )
350*
351* Generate reflection Q(i) to annihilate A(i+2:m,i)
352*
353 CALL dlarfg( m-i, a( i+1, i ), a( min( i+2, m ), i ), 1,
354 $ tauq( i ) )
355 e( i ) = a( i+1, i )
356 a( i+1, i ) = one
357*
358* Compute Y(i+1:n,i)
359*
360 CALL dgemv( 'Transpose', m-i, n-i, one, a( i+1, i+1 ),
361 $ lda, a( i+1, i ), 1, zero, y( i+1, i ), 1 )
362 CALL dgemv( 'Transpose', m-i, i-1, one, a( i+1, 1 ), lda,
363 $ a( i+1, i ), 1, zero, y( 1, i ), 1 )
364 CALL dgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
365 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
366 CALL dgemv( 'Transpose', m-i, i, one, x( i+1, 1 ), ldx,
367 $ a( i+1, i ), 1, zero, y( 1, i ), 1 )
368 CALL dgemv( 'Transpose', i, n-i, -one, a( 1, i+1 ), lda,
369 $ y( 1, i ), 1, one, y( i+1, i ), 1 )
370 CALL dscal( n-i, tauq( i ), y( i+1, i ), 1 )
371 END IF
372 20 CONTINUE
373 END IF
374 RETURN
375*
376* End of DLABRD
377*
dlarfg
subroutine dlarfg(n, alpha, x, incx, tau)
DLARFG generates an elementary reflector (Householder matrix).
Definition dlarfg.f:106
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dgemv
subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
DGEMV
Definition dgemv.f:156
min
#define min(a, b)
Definition macros.h:20

◆ dlacn2()

subroutine dlacn2 ( integer n,
double precision, dimension( * ) v,
double precision, dimension( * ) x,
integer, dimension( * ) isgn,
double precision est,
integer kase,
integer, dimension( 3 ) isave )

DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.

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

Purpose:
!>
!> DLACN2 estimates the 1-norm of a square, real matrix A.
!> Reverse communication is used for evaluating matrix-vector products.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The order of the matrix.  N >= 1.
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (N)
!>         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!>         (W is not returned).
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (N)
!>         On an intermediate return, X should be overwritten by
!>               A * X,   if KASE=1,
!>               A**T * X,  if KASE=2,
!>         and DLACN2 must be re-called with all the other parameters
!>         unchanged.
!>
[out]ISGN
!>          ISGN is INTEGER array, dimension (N)
!>
[in,out]EST
!>          EST is DOUBLE PRECISION
!>         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
!>         unchanged from the previous call to DLACN2.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to DLACN2, KASE should be 0.
!>         On an intermediate return, KASE will be 1 or 2, indicating
!>         whether X should be overwritten by A * X  or A**T * X.
!>         On the final return from DLACN2, KASE will again be 0.
!>
[in,out]ISAVE
!>          ISAVE is INTEGER array, dimension (3)
!>         ISAVE is used to save variables between calls to DLACN2
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Originally named SONEST, dated March 16, 1988.
!>
!>  This is a thread safe version of DLACON, which uses the array ISAVE
!>  in place of a SAVE statement, as follows:
!>
!>     DLACON     DLACN2
!>      JUMP     ISAVE(1)
!>      J        ISAVE(2)
!>      ITER     ISAVE(3)
!>
Contributors:
Nick Higham, University of Manchester
References:
N.J. Higham, "FORTRAN codes for estimating the one-norm of a real or complex matrix, with applications to condition estimation", ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.

Definition at line 135 of file dlacn2.f.

136*
137* -- LAPACK auxiliary routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER KASE, N
143 DOUBLE PRECISION EST
144* ..
145* .. Array Arguments ..
146 INTEGER ISGN( * ), ISAVE( 3 )
147 DOUBLE PRECISION V( * ), X( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 INTEGER ITMAX
154 parameter( itmax = 5 )
155 DOUBLE PRECISION ZERO, ONE, TWO
156 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
157* ..
158* .. Local Scalars ..
159 INTEGER I, JLAST
160 DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS
161* ..
162* .. External Functions ..
163 INTEGER IDAMAX
164 DOUBLE PRECISION DASUM
165 EXTERNAL idamax, dasum
166* ..
167* .. External Subroutines ..
168 EXTERNAL dcopy
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, nint
172* ..
173* .. Executable Statements ..
174*
175 IF( kase.EQ.0 ) THEN
176 DO 10 i = 1, n
177 x( i ) = one / dble( n )
178 10 CONTINUE
179 kase = 1
180 isave( 1 ) = 1
181 RETURN
182 END IF
183*
184 GO TO ( 20, 40, 70, 110, 140 )isave( 1 )
185*
186* ................ ENTRY (ISAVE( 1 ) = 1)
187* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
188*
189 20 CONTINUE
190 IF( n.EQ.1 ) THEN
191 v( 1 ) = x( 1 )
192 est = abs( v( 1 ) )
193* ... QUIT
194 GO TO 150
195 END IF
196 est = dasum( n, x, 1 )
197*
198 DO 30 i = 1, n
199 IF( x(i).GE.zero ) THEN
200 x(i) = one
201 ELSE
202 x(i) = -one
203 END IF
204 isgn( i ) = nint( x( i ) )
205 30 CONTINUE
206 kase = 2
207 isave( 1 ) = 2
208 RETURN
209*
210* ................ ENTRY (ISAVE( 1 ) = 2)
211* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
212*
213 40 CONTINUE
214 isave( 2 ) = idamax( n, x, 1 )
215 isave( 3 ) = 2
216*
217* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
218*
219 50 CONTINUE
220 DO 60 i = 1, n
221 x( i ) = zero
222 60 CONTINUE
223 x( isave( 2 ) ) = one
224 kase = 1
225 isave( 1 ) = 3
226 RETURN
227*
228* ................ ENTRY (ISAVE( 1 ) = 3)
229* X HAS BEEN OVERWRITTEN BY A*X.
230*
231 70 CONTINUE
232 CALL dcopy( n, x, 1, v, 1 )
233 estold = est
234 est = dasum( n, v, 1 )
235 DO 80 i = 1, n
236 IF( x(i).GE.zero ) THEN
237 xs = one
238 ELSE
239 xs = -one
240 END IF
241 IF( nint( xs ).NE.isgn( i ) )
242 $ GO TO 90
243 80 CONTINUE
244* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
245 GO TO 120
246*
247 90 CONTINUE
248* TEST FOR CYCLING.
249 IF( est.LE.estold )
250 $ GO TO 120
251*
252 DO 100 i = 1, n
253 IF( x(i).GE.zero ) THEN
254 x(i) = one
255 ELSE
256 x(i) = -one
257 END IF
258 isgn( i ) = nint( x( i ) )
259 100 CONTINUE
260 kase = 2
261 isave( 1 ) = 4
262 RETURN
263*
264* ................ ENTRY (ISAVE( 1 ) = 4)
265* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
266*
267 110 CONTINUE
268 jlast = isave( 2 )
269 isave( 2 ) = idamax( n, x, 1 )
270 IF( ( x( jlast ).NE.abs( x( isave( 2 ) ) ) ) .AND.
271 $ ( isave( 3 ).LT.itmax ) ) THEN
272 isave( 3 ) = isave( 3 ) + 1
273 GO TO 50
274 END IF
275*
276* ITERATION COMPLETE. FINAL STAGE.
277*
278 120 CONTINUE
279 altsgn = one
280 DO 130 i = 1, n
281 x( i ) = altsgn*( one+dble( i-1 ) / dble( n-1 ) )
282 altsgn = -altsgn
283 130 CONTINUE
284 kase = 1
285 isave( 1 ) = 5
286 RETURN
287*
288* ................ ENTRY (ISAVE( 1 ) = 5)
289* X HAS BEEN OVERWRITTEN BY A*X.
290*
291 140 CONTINUE
292 temp = two*( dasum( n, x, 1 ) / dble( 3*n ) )
293 IF( temp.GT.est ) THEN
294 CALL dcopy( n, x, 1, v, 1 )
295 est = temp
296 END IF
297*
298 150 CONTINUE
299 kase = 0
300 RETURN
301*
302* End of DLACN2
303*
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
dasum
double precision function dasum(n, dx, incx)
DASUM
Definition dasum.f:71
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ dlacon()

subroutine dlacon ( integer n,
double precision, dimension( * ) v,
double precision, dimension( * ) x,
integer, dimension( * ) isgn,
double precision est,
integer kase )

DLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.

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

Purpose:
!>
!> DLACON estimates the 1-norm of a square, real matrix A.
!> Reverse communication is used for evaluating matrix-vector products.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The order of the matrix.  N >= 1.
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (N)
!>         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!>         (W is not returned).
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (N)
!>         On an intermediate return, X should be overwritten by
!>               A * X,   if KASE=1,
!>               A**T * X,  if KASE=2,
!>         and DLACON must be re-called with all the other parameters
!>         unchanged.
!>
[out]ISGN
!>          ISGN is INTEGER array, dimension (N)
!>
[in,out]EST
!>          EST is DOUBLE PRECISION
!>         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
!>         unchanged from the previous call to DLACON.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to DLACON, KASE should be 0.
!>         On an intermediate return, KASE will be 1 or 2, indicating
!>         whether X should be overwritten by A * X  or A**T * X.
!>         On the final return from DLACON, KASE will again be 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Nick Higham, University of Manchester.
Originally named SONEST, dated March 16, 1988.
References:
N.J. Higham, "FORTRAN codes for estimating the one-norm of a real or complex matrix, with applications to condition estimation", ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.

Definition at line 114 of file dlacon.f.

115*
116* -- LAPACK auxiliary routine --
117* -- LAPACK is a software package provided by Univ. of Tennessee, --
118* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
119*
120* .. Scalar Arguments ..
121 INTEGER KASE, N
122 DOUBLE PRECISION EST
123* ..
124* .. Array Arguments ..
125 INTEGER ISGN( * )
126 DOUBLE PRECISION V( * ), X( * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 INTEGER ITMAX
133 parameter( itmax = 5 )
134 DOUBLE PRECISION ZERO, ONE, TWO
135 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
136* ..
137* .. Local Scalars ..
138 INTEGER I, ITER, J, JLAST, JUMP
139 DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
140* ..
141* .. External Functions ..
142 INTEGER IDAMAX
143 DOUBLE PRECISION DASUM
144 EXTERNAL idamax, dasum
145* ..
146* .. External Subroutines ..
147 EXTERNAL dcopy
148* ..
149* .. Intrinsic Functions ..
150 INTRINSIC abs, dble, nint, sign
151* ..
152* .. Save statement ..
153 SAVE
154* ..
155* .. Executable Statements ..
156*
157 IF( kase.EQ.0 ) THEN
158 DO 10 i = 1, n
159 x( i ) = one / dble( n )
160 10 CONTINUE
161 kase = 1
162 jump = 1
163 RETURN
164 END IF
165*
166 GO TO ( 20, 40, 70, 110, 140 )jump
167*
168* ................ ENTRY (JUMP = 1)
169* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
170*
171 20 CONTINUE
172 IF( n.EQ.1 ) THEN
173 v( 1 ) = x( 1 )
174 est = abs( v( 1 ) )
175* ... QUIT
176 GO TO 150
177 END IF
178 est = dasum( n, x, 1 )
179*
180 DO 30 i = 1, n
181 x( i ) = sign( one, x( i ) )
182 isgn( i ) = nint( x( i ) )
183 30 CONTINUE
184 kase = 2
185 jump = 2
186 RETURN
187*
188* ................ ENTRY (JUMP = 2)
189* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
190*
191 40 CONTINUE
192 j = idamax( n, x, 1 )
193 iter = 2
194*
195* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
196*
197 50 CONTINUE
198 DO 60 i = 1, n
199 x( i ) = zero
200 60 CONTINUE
201 x( j ) = one
202 kase = 1
203 jump = 3
204 RETURN
205*
206* ................ ENTRY (JUMP = 3)
207* X HAS BEEN OVERWRITTEN BY A*X.
208*
209 70 CONTINUE
210 CALL dcopy( n, x, 1, v, 1 )
211 estold = est
212 est = dasum( n, v, 1 )
213 DO 80 i = 1, n
214 IF( nint( sign( one, x( i ) ) ).NE.isgn( i ) )
215 $ GO TO 90
216 80 CONTINUE
217* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
218 GO TO 120
219*
220 90 CONTINUE
221* TEST FOR CYCLING.
222 IF( est.LE.estold )
223 $ GO TO 120
224*
225 DO 100 i = 1, n
226 x( i ) = sign( one, x( i ) )
227 isgn( i ) = nint( x( i ) )
228 100 CONTINUE
229 kase = 2
230 jump = 4
231 RETURN
232*
233* ................ ENTRY (JUMP = 4)
234* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
235*
236 110 CONTINUE
237 jlast = j
238 j = idamax( n, x, 1 )
239 IF( ( x( jlast ).NE.abs( x( j ) ) ) .AND. ( iter.LT.itmax ) ) THEN
240 iter = iter + 1
241 GO TO 50
242 END IF
243*
244* ITERATION COMPLETE. FINAL STAGE.
245*
246 120 CONTINUE
247 altsgn = one
248 DO 130 i = 1, n
249 x( i ) = altsgn*( one+dble( i-1 ) / dble( n-1 ) )
250 altsgn = -altsgn
251 130 CONTINUE
252 kase = 1
253 jump = 5
254 RETURN
255*
256* ................ ENTRY (JUMP = 5)
257* X HAS BEEN OVERWRITTEN BY A*X.
258*
259 140 CONTINUE
260 temp = two*( dasum( n, x, 1 ) / dble( 3*n ) )
261 IF( temp.GT.est ) THEN
262 CALL dcopy( n, x, 1, v, 1 )
263 est = temp
264 END IF
265*
266 150 CONTINUE
267 kase = 0
268 RETURN
269*
270* End of DLACON
271*

◆ dladiv()

subroutine dladiv ( double precision a,
double precision b,
double precision c,
double precision d,
double precision p,
double precision q )

DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.

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

Purpose:
!>
!> DLADIV performs complex division in  real arithmetic
!>
!>                       a + i*b
!>            p + i*q = ---------
!>                       c + i*d
!>
!> The algorithm is due to Michael Baudin and Robert L. Smith
!> and can be found in the paper
!> 
!>
Parameters
[in]A
!>          A is DOUBLE PRECISION
!>
[in]B
!>          B is DOUBLE PRECISION
!>
[in]C
!>          C is DOUBLE PRECISION
!>
[in]D
!>          D is DOUBLE PRECISION
!>          The scalars a, b, c, and d in the above expression.
!>
[out]P
!>          P is DOUBLE PRECISION
!>
[out]Q
!>          Q is DOUBLE PRECISION
!>          The scalars p and q in the above expression.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file dladiv.f.

91*
92* -- LAPACK auxiliary 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 DOUBLE PRECISION A, B, C, D, P, Q
98* ..
99*
100* =====================================================================
101*
102* .. Parameters ..
103 DOUBLE PRECISION BS
104 parameter( bs = 2.0d0 )
105 DOUBLE PRECISION HALF
106 parameter( half = 0.5d0 )
107 DOUBLE PRECISION TWO
108 parameter( two = 2.0d0 )
109*
110* .. Local Scalars ..
111 DOUBLE PRECISION AA, BB, CC, DD, AB, CD, S, OV, UN, BE, EPS
112* ..
113* .. External Functions ..
114 DOUBLE PRECISION DLAMCH
115 EXTERNAL dlamch
116* ..
117* .. External Subroutines ..
118 EXTERNAL dladiv1
119* ..
120* .. Intrinsic Functions ..
121 INTRINSIC abs, max
122* ..
123* .. Executable Statements ..
124*
125 aa = a
126 bb = b
127 cc = c
128 dd = d
129 ab = max( abs(a), abs(b) )
130 cd = max( abs(c), abs(d) )
131 s = 1.0d0
132
133 ov = dlamch( 'Overflow threshold' )
134 un = dlamch( 'Safe minimum' )
135 eps = dlamch( 'Epsilon' )
136 be = bs / (eps*eps)
137
138 IF( ab >= half*ov ) THEN
139 aa = half * aa
140 bb = half * bb
141 s = two * s
142 END IF
143 IF( cd >= half*ov ) THEN
144 cc = half * cc
145 dd = half * dd
146 s = half * s
147 END IF
148 IF( ab <= un*bs/eps ) THEN
149 aa = aa * be
150 bb = bb * be
151 s = s / be
152 END IF
153 IF( cd <= un*bs/eps ) THEN
154 cc = cc * be
155 dd = dd * be
156 s = s * be
157 END IF
158 IF( abs( d ).LE.abs( c ) ) THEN
159 CALL dladiv1(aa, bb, cc, dd, p, q)
160 ELSE
161 CALL dladiv1(bb, aa, dd, cc, p, q)
162 q = -q
163 END IF
164 p = p * s
165 q = q * s
166*
167 RETURN
168*
169* End of DLADIV
170*
dladiv1
subroutine dladiv1(a, b, c, d, p, q)
Definition dladiv.f:177
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
max
#define max(a, b)
Definition macros.h:21

◆ dladiv1()

subroutine dladiv1 ( double precision a,
double precision b,
double precision c,
double precision d,
double precision p,
double precision q )

Definition at line 176 of file dladiv.f.

177*
178* -- LAPACK auxiliary routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 DOUBLE PRECISION A, B, C, D, P, Q
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ONE
190 parameter( one = 1.0d0 )
191*
192* .. Local Scalars ..
193 DOUBLE PRECISION R, T
194* ..
195* .. External Functions ..
196 DOUBLE PRECISION DLADIV2
197 EXTERNAL dladiv2
198* ..
199* .. Executable Statements ..
200*
201 r = d / c
202 t = one / (c + d * r)
203 p = dladiv2(a, b, c, d, r, t)
204 a = -a
205 q = dladiv2(b, a, c, d, r, t)
206*
207 RETURN
208*
209* End of DLADIV1
210*
dladiv2
double precision function dladiv2(a, b, c, d, r, t)
Definition dladiv.f:216

◆ dladiv2()

double precision function dladiv2 ( double precision a,
double precision b,
double precision c,
double precision d,
double precision r,
double precision t )

Definition at line 215 of file dladiv.f.

216*
217* -- LAPACK auxiliary routine --
218* -- LAPACK is a software package provided by Univ. of Tennessee, --
219* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
220*
221* .. Scalar Arguments ..
222 DOUBLE PRECISION A, B, C, D, R, T
223* ..
224*
225* =====================================================================
226*
227* .. Parameters ..
228 DOUBLE PRECISION ZERO
229 parameter( zero = 0.0d0 )
230*
231* .. Local Scalars ..
232 DOUBLE PRECISION BR
233* ..
234* .. Executable Statements ..
235*
236 IF( r.NE.zero ) THEN
237 br = b * r
238 IF( br.NE.zero ) THEN
239 dladiv2 = (a + br) * t
240 ELSE
241 dladiv2 = a * t + (b * t) * r
242 END IF
243 ELSE
244 dladiv2 = (a + d * (b / c)) * t
245 END IF
246*
247 RETURN
248*
249* End of DLADIV2
250*

◆ dlaein()

subroutine dlaein ( logical rightv,
logical noinit,
integer n,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision wr,
double precision wi,
double precision, dimension( * ) vr,
double precision, dimension( * ) vi,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) work,
double precision eps3,
double precision smlnum,
double precision bignum,
integer info )

DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration.

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

Purpose:
!>
!> DLAEIN uses inverse iteration to find a right or left eigenvector
!> corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!> matrix H.
!>
Parameters
[in]RIGHTV
!>          RIGHTV is LOGICAL
!>          = .TRUE. : compute right eigenvector;
!>          = .FALSE.: compute left eigenvector.
!>
[in]NOINIT
!>          NOINIT is LOGICAL
!>          = .TRUE. : no initial vector supplied in (VR,VI).
!>          = .FALSE.: initial vector supplied in (VR,VI).
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H.  N >= 0.
!>
[in]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          The upper Hessenberg matrix H.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max(1,N).
!>
[in]WR
!>          WR is DOUBLE PRECISION
!>
[in]WI
!>          WI is DOUBLE PRECISION
!>          The real and imaginary parts of the eigenvalue of H whose
!>          corresponding right or left eigenvector is to be computed.
!>
[in,out]VR
!>          VR is DOUBLE PRECISION array, dimension (N)
!>
[in,out]VI
!>          VI is DOUBLE PRECISION array, dimension (N)
!>          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
!>          a real starting vector for inverse iteration using the real
!>          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
!>          must contain the real and imaginary parts of a complex
!>          starting vector for inverse iteration using the complex
!>          eigenvalue (WR,WI); otherwise VR and VI need not be set.
!>          On exit, if WI = 0.0 (real eigenvalue), VR contains the
!>          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
!>          VR and VI contain the real and imaginary parts of the
!>          computed complex eigenvector. The eigenvector is normalized
!>          so that the component of largest magnitude has magnitude 1;
!>          here the magnitude of a complex number (x,y) is taken to be
!>          |x| + |y|.
!>          VI is not referenced if WI = 0.0.
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= N+1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[in]EPS3
!>          EPS3 is DOUBLE PRECISION
!>          A small machine-dependent value which is used to perturb
!>          close eigenvalues, and to replace zero pivots.
!>
[in]SMLNUM
!>          SMLNUM is DOUBLE PRECISION
!>          A machine-dependent value close to the underflow threshold.
!>
[in]BIGNUM
!>          BIGNUM is DOUBLE PRECISION
!>          A machine-dependent value close to the overflow threshold.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          = 1:  inverse iteration did not converge; VR is set to the
!>                last iterate, and so is VI if WI.ne.0.0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 170 of file dlaein.f.

172*
173* -- LAPACK auxiliary 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 LOGICAL NOINIT, RIGHTV
179 INTEGER INFO, LDB, LDH, N
180 DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR
181* ..
182* .. Array Arguments ..
183 DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
184 $ WORK( * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 DOUBLE PRECISION ZERO, ONE, TENTH
191 parameter( zero = 0.0d+0, one = 1.0d+0, tenth = 1.0d-1 )
192* ..
193* .. Local Scalars ..
194 CHARACTER NORMIN, TRANS
195 INTEGER I, I1, I2, I3, IERR, ITS, J
196 DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
197 $ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
198 $ W1, X, XI, XR, Y
199* ..
200* .. External Functions ..
201 INTEGER IDAMAX
202 DOUBLE PRECISION DASUM, DLAPY2, DNRM2
203 EXTERNAL idamax, dasum, dlapy2, dnrm2
204* ..
205* .. External Subroutines ..
206 EXTERNAL dladiv, dlatrs, dscal
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs, dble, max, sqrt
210* ..
211* .. Executable Statements ..
212*
213 info = 0
214*
215* GROWTO is the threshold used in the acceptance test for an
216* eigenvector.
217*
218 rootn = sqrt( dble( n ) )
219 growto = tenth / rootn
220 nrmsml = max( one, eps3*rootn )*smlnum
221*
222* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
223* the imaginary parts of the diagonal elements are not stored).
224*
225 DO 20 j = 1, n
226 DO 10 i = 1, j - 1
227 b( i, j ) = h( i, j )
228 10 CONTINUE
229 b( j, j ) = h( j, j ) - wr
230 20 CONTINUE
231*
232 IF( wi.EQ.zero ) THEN
233*
234* Real eigenvalue.
235*
236 IF( noinit ) THEN
237*
238* Set initial vector.
239*
240 DO 30 i = 1, n
241 vr( i ) = eps3
242 30 CONTINUE
243 ELSE
244*
245* Scale supplied initial vector.
246*
247 vnorm = dnrm2( n, vr, 1 )
248 CALL dscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,
249 $ 1 )
250 END IF
251*
252 IF( rightv ) THEN
253*
254* LU decomposition with partial pivoting of B, replacing zero
255* pivots by EPS3.
256*
257 DO 60 i = 1, n - 1
258 ei = h( i+1, i )
259 IF( abs( b( i, i ) ).LT.abs( ei ) ) THEN
260*
261* Interchange rows and eliminate.
262*
263 x = b( i, i ) / ei
264 b( i, i ) = ei
265 DO 40 j = i + 1, n
266 temp = b( i+1, j )
267 b( i+1, j ) = b( i, j ) - x*temp
268 b( i, j ) = temp
269 40 CONTINUE
270 ELSE
271*
272* Eliminate without interchange.
273*
274 IF( b( i, i ).EQ.zero )
275 $ b( i, i ) = eps3
276 x = ei / b( i, i )
277 IF( x.NE.zero ) THEN
278 DO 50 j = i + 1, n
279 b( i+1, j ) = b( i+1, j ) - x*b( i, j )
280 50 CONTINUE
281 END IF
282 END IF
283 60 CONTINUE
284 IF( b( n, n ).EQ.zero )
285 $ b( n, n ) = eps3
286*
287 trans = 'N'
288*
289 ELSE
290*
291* UL decomposition with partial pivoting of B, replacing zero
292* pivots by EPS3.
293*
294 DO 90 j = n, 2, -1
295 ej = h( j, j-1 )
296 IF( abs( b( j, j ) ).LT.abs( ej ) ) THEN
297*
298* Interchange columns and eliminate.
299*
300 x = b( j, j ) / ej
301 b( j, j ) = ej
302 DO 70 i = 1, j - 1
303 temp = b( i, j-1 )
304 b( i, j-1 ) = b( i, j ) - x*temp
305 b( i, j ) = temp
306 70 CONTINUE
307 ELSE
308*
309* Eliminate without interchange.
310*
311 IF( b( j, j ).EQ.zero )
312 $ b( j, j ) = eps3
313 x = ej / b( j, j )
314 IF( x.NE.zero ) THEN
315 DO 80 i = 1, j - 1
316 b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
317 80 CONTINUE
318 END IF
319 END IF
320 90 CONTINUE
321 IF( b( 1, 1 ).EQ.zero )
322 $ b( 1, 1 ) = eps3
323*
324 trans = 'T'
325*
326 END IF
327*
328 normin = 'N'
329 DO 110 its = 1, n
330*
331* Solve U*x = scale*v for a right eigenvector
332* or U**T*x = scale*v for a left eigenvector,
333* overwriting x on v.
334*
335 CALL dlatrs( 'Upper', trans, 'Nonunit', normin, n, b, ldb,
336 $ vr, scale, work, ierr )
337 normin = 'Y'
338*
339* Test for sufficient growth in the norm of v.
340*
341 vnorm = dasum( n, vr, 1 )
342 IF( vnorm.GE.growto*scale )
343 $ GO TO 120
344*
345* Choose new orthogonal starting vector and try again.
346*
347 temp = eps3 / ( rootn+one )
348 vr( 1 ) = eps3
349 DO 100 i = 2, n
350 vr( i ) = temp
351 100 CONTINUE
352 vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
353 110 CONTINUE
354*
355* Failure to find eigenvector in N iterations.
356*
357 info = 1
358*
359 120 CONTINUE
360*
361* Normalize eigenvector.
362*
363 i = idamax( n, vr, 1 )
364 CALL dscal( n, one / abs( vr( i ) ), vr, 1 )
365 ELSE
366*
367* Complex eigenvalue.
368*
369 IF( noinit ) THEN
370*
371* Set initial vector.
372*
373 DO 130 i = 1, n
374 vr( i ) = eps3
375 vi( i ) = zero
376 130 CONTINUE
377 ELSE
378*
379* Scale supplied initial vector.
380*
381 norm = dlapy2( dnrm2( n, vr, 1 ), dnrm2( n, vi, 1 ) )
382 rec = ( eps3*rootn ) / max( norm, nrmsml )
383 CALL dscal( n, rec, vr, 1 )
384 CALL dscal( n, rec, vi, 1 )
385 END IF
386*
387 IF( rightv ) THEN
388*
389* LU decomposition with partial pivoting of B, replacing zero
390* pivots by EPS3.
391*
392* The imaginary part of the (i,j)-th element of U is stored in
393* B(j+1,i).
394*
395 b( 2, 1 ) = -wi
396 DO 140 i = 2, n
397 b( i+1, 1 ) = zero
398 140 CONTINUE
399*
400 DO 170 i = 1, n - 1
401 absbii = dlapy2( b( i, i ), b( i+1, i ) )
402 ei = h( i+1, i )
403 IF( absbii.LT.abs( ei ) ) THEN
404*
405* Interchange rows and eliminate.
406*
407 xr = b( i, i ) / ei
408 xi = b( i+1, i ) / ei
409 b( i, i ) = ei
410 b( i+1, i ) = zero
411 DO 150 j = i + 1, n
412 temp = b( i+1, j )
413 b( i+1, j ) = b( i, j ) - xr*temp
414 b( j+1, i+1 ) = b( j+1, i ) - xi*temp
415 b( i, j ) = temp
416 b( j+1, i ) = zero
417 150 CONTINUE
418 b( i+2, i ) = -wi
419 b( i+1, i+1 ) = b( i+1, i+1 ) - xi*wi
420 b( i+2, i+1 ) = b( i+2, i+1 ) + xr*wi
421 ELSE
422*
423* Eliminate without interchanging rows.
424*
425 IF( absbii.EQ.zero ) THEN
426 b( i, i ) = eps3
427 b( i+1, i ) = zero
428 absbii = eps3
429 END IF
430 ei = ( ei / absbii ) / absbii
431 xr = b( i, i )*ei
432 xi = -b( i+1, i )*ei
433 DO 160 j = i + 1, n
434 b( i+1, j ) = b( i+1, j ) - xr*b( i, j ) +
435 $ xi*b( j+1, i )
436 b( j+1, i+1 ) = -xr*b( j+1, i ) - xi*b( i, j )
437 160 CONTINUE
438 b( i+2, i+1 ) = b( i+2, i+1 ) - wi
439 END IF
440*
441* Compute 1-norm of offdiagonal elements of i-th row.
442*
443 work( i ) = dasum( n-i, b( i, i+1 ), ldb ) +
444 $ dasum( n-i, b( i+2, i ), 1 )
445 170 CONTINUE
446 IF( b( n, n ).EQ.zero .AND. b( n+1, n ).EQ.zero )
447 $ b( n, n ) = eps3
448 work( n ) = zero
449*
450 i1 = n
451 i2 = 1
452 i3 = -1
453 ELSE
454*
455* UL decomposition with partial pivoting of conjg(B),
456* replacing zero pivots by EPS3.
457*
458* The imaginary part of the (i,j)-th element of U is stored in
459* B(j+1,i).
460*
461 b( n+1, n ) = wi
462 DO 180 j = 1, n - 1
463 b( n+1, j ) = zero
464 180 CONTINUE
465*
466 DO 210 j = n, 2, -1
467 ej = h( j, j-1 )
468 absbjj = dlapy2( b( j, j ), b( j+1, j ) )
469 IF( absbjj.LT.abs( ej ) ) THEN
470*
471* Interchange columns and eliminate
472*
473 xr = b( j, j ) / ej
474 xi = b( j+1, j ) / ej
475 b( j, j ) = ej
476 b( j+1, j ) = zero
477 DO 190 i = 1, j - 1
478 temp = b( i, j-1 )
479 b( i, j-1 ) = b( i, j ) - xr*temp
480 b( j, i ) = b( j+1, i ) - xi*temp
481 b( i, j ) = temp
482 b( j+1, i ) = zero
483 190 CONTINUE
484 b( j+1, j-1 ) = wi
485 b( j-1, j-1 ) = b( j-1, j-1 ) + xi*wi
486 b( j, j-1 ) = b( j, j-1 ) - xr*wi
487 ELSE
488*
489* Eliminate without interchange.
490*
491 IF( absbjj.EQ.zero ) THEN
492 b( j, j ) = eps3
493 b( j+1, j ) = zero
494 absbjj = eps3
495 END IF
496 ej = ( ej / absbjj ) / absbjj
497 xr = b( j, j )*ej
498 xi = -b( j+1, j )*ej
499 DO 200 i = 1, j - 1
500 b( i, j-1 ) = b( i, j-1 ) - xr*b( i, j ) +
501 $ xi*b( j+1, i )
502 b( j, i ) = -xr*b( j+1, i ) - xi*b( i, j )
503 200 CONTINUE
504 b( j, j-1 ) = b( j, j-1 ) + wi
505 END IF
506*
507* Compute 1-norm of offdiagonal elements of j-th column.
508*
509 work( j ) = dasum( j-1, b( 1, j ), 1 ) +
510 $ dasum( j-1, b( j+1, 1 ), ldb )
511 210 CONTINUE
512 IF( b( 1, 1 ).EQ.zero .AND. b( 2, 1 ).EQ.zero )
513 $ b( 1, 1 ) = eps3
514 work( 1 ) = zero
515*
516 i1 = 1
517 i2 = n
518 i3 = 1
519 END IF
520*
521 DO 270 its = 1, n
522 scale = one
523 vmax = one
524 vcrit = bignum
525*
526* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
527* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector,
528* overwriting (xr,xi) on (vr,vi).
529*
530 DO 250 i = i1, i2, i3
531*
532 IF( work( i ).GT.vcrit ) THEN
533 rec = one / vmax
534 CALL dscal( n, rec, vr, 1 )
535 CALL dscal( n, rec, vi, 1 )
536 scale = scale*rec
537 vmax = one
538 vcrit = bignum
539 END IF
540*
541 xr = vr( i )
542 xi = vi( i )
543 IF( rightv ) THEN
544 DO 220 j = i + 1, n
545 xr = xr - b( i, j )*vr( j ) + b( j+1, i )*vi( j )
546 xi = xi - b( i, j )*vi( j ) - b( j+1, i )*vr( j )
547 220 CONTINUE
548 ELSE
549 DO 230 j = 1, i - 1
550 xr = xr - b( j, i )*vr( j ) + b( i+1, j )*vi( j )
551 xi = xi - b( j, i )*vi( j ) - b( i+1, j )*vr( j )
552 230 CONTINUE
553 END IF
554*
555 w = abs( b( i, i ) ) + abs( b( i+1, i ) )
556 IF( w.GT.smlnum ) THEN
557 IF( w.LT.one ) THEN
558 w1 = abs( xr ) + abs( xi )
559 IF( w1.GT.w*bignum ) THEN
560 rec = one / w1
561 CALL dscal( n, rec, vr, 1 )
562 CALL dscal( n, rec, vi, 1 )
563 xr = vr( i )
564 xi = vi( i )
565 scale = scale*rec
566 vmax = vmax*rec
567 END IF
568 END IF
569*
570* Divide by diagonal element of B.
571*
572 CALL dladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),
573 $ vi( i ) )
574 vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax )
575 vcrit = bignum / vmax
576 ELSE
577 DO 240 j = 1, n
578 vr( j ) = zero
579 vi( j ) = zero
580 240 CONTINUE
581 vr( i ) = one
582 vi( i ) = one
583 scale = zero
584 vmax = one
585 vcrit = bignum
586 END IF
587 250 CONTINUE
588*
589* Test for sufficient growth in the norm of (VR,VI).
590*
591 vnorm = dasum( n, vr, 1 ) + dasum( n, vi, 1 )
592 IF( vnorm.GE.growto*scale )
593 $ GO TO 280
594*
595* Choose a new orthogonal starting vector and try again.
596*
597 y = eps3 / ( rootn+one )
598 vr( 1 ) = eps3
599 vi( 1 ) = zero
600*
601 DO 260 i = 2, n
602 vr( i ) = y
603 vi( i ) = zero
604 260 CONTINUE
605 vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn
606 270 CONTINUE
607*
608* Failure to find eigenvector in N iterations
609*
610 info = 1
611*
612 280 CONTINUE
613*
614* Normalize eigenvector.
615*
616 vnorm = zero
617 DO 290 i = 1, n
618 vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) )
619 290 CONTINUE
620 CALL dscal( n, one / vnorm, vr, 1 )
621 CALL dscal( n, one / vnorm, vi, 1 )
622*
623 END IF
624*
625 RETURN
626*
627* End of DLAEIN
628*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63
dlatrs
subroutine dlatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
DLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition dlatrs.f:238
dladiv
subroutine dladiv(a, b, c, d, p, q)
DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition dladiv.f:91
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89

◆ dlaexc()

subroutine dlaexc ( logical wantq,
integer n,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( ldq, * ) q,
integer ldq,
integer j1,
integer n1,
integer n2,
double precision, dimension( * ) work,
integer info )

DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form, by an orthogonal similarity transformation.

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

Purpose:
!>
!> DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
!> an upper quasi-triangular matrix T by an orthogonal similarity
!> transformation.
!>
!> T must be in Schur canonical form, that is, block upper triangular
!> with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
!> has its diagonal elements equal and its off-diagonal elements of
!> opposite sign.
!>
Parameters
[in]WANTQ
!>          WANTQ is LOGICAL
!>          = .TRUE. : accumulate the transformation in the matrix Q;
!>          = .FALSE.: do not accumulate the transformation.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!>
[in,out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,N)
!>          On entry, the upper quasi-triangular matrix T, in Schur
!>          canonical form.
!>          On exit, the updated matrix T, again in Schur canonical form.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!>
[in,out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDQ,N)
!>          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
!>          On exit, if WANTQ is .TRUE., the updated matrix Q.
!>          If WANTQ is .FALSE., Q is not referenced.
!>
[in]LDQ
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
!>
[in]J1
!>          J1 is INTEGER
!>          The index of the first row of the first block T11.
!>
[in]N1
!>          N1 is INTEGER
!>          The order of the first block T11. N1 = 0, 1 or 2.
!>
[in]N2
!>          N2 is INTEGER
!>          The order of the second block T22. N2 = 0, 1 or 2.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          = 1: the transformed matrix T would be too far from Schur
!>               form; the blocks are not swapped and T and Q are
!>               unchanged.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 136 of file dlaexc.f.

138*
139* -- LAPACK auxiliary routine --
140* -- LAPACK is a software package provided by Univ. of Tennessee, --
141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142*
143* .. Scalar Arguments ..
144 LOGICAL WANTQ
145 INTEGER INFO, J1, LDQ, LDT, N, N1, N2
146* ..
147* .. Array Arguments ..
148 DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
149* ..
150*
151* =====================================================================
152*
153* .. Parameters ..
154 DOUBLE PRECISION ZERO, ONE
155 parameter( zero = 0.0d+0, one = 1.0d+0 )
156 DOUBLE PRECISION TEN
157 parameter( ten = 1.0d+1 )
158 INTEGER LDD, LDX
159 parameter( ldd = 4, ldx = 2 )
160* ..
161* .. Local Scalars ..
162 INTEGER IERR, J2, J3, J4, K, ND
163 DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
164 $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
165 $ WR1, WR2, XNORM
166* ..
167* .. Local Arrays ..
168 DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
169 $ X( LDX, 2 )
170* ..
171* .. External Functions ..
172 DOUBLE PRECISION DLAMCH, DLANGE
173 EXTERNAL dlamch, dlange
174* ..
175* .. External Subroutines ..
176 EXTERNAL dlacpy, dlanv2, dlarfg, dlarfx, dlartg, dlasy2,
177 $ drot
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC abs, max
181* ..
182* .. Executable Statements ..
183*
184 info = 0
185*
186* Quick return if possible
187*
188 IF( n.EQ.0 .OR. n1.EQ.0 .OR. n2.EQ.0 )
189 $ RETURN
190 IF( j1+n1.GT.n )
191 $ RETURN
192*
193 j2 = j1 + 1
194 j3 = j1 + 2
195 j4 = j1 + 3
196*
197 IF( n1.EQ.1 .AND. n2.EQ.1 ) THEN
198*
199* Swap two 1-by-1 blocks.
200*
201 t11 = t( j1, j1 )
202 t22 = t( j2, j2 )
203*
204* Determine the transformation to perform the interchange.
205*
206 CALL dlartg( t( j1, j2 ), t22-t11, cs, sn, temp )
207*
208* Apply transformation to the matrix T.
209*
210 IF( j3.LE.n )
211 $ CALL drot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,
212 $ sn )
213 CALL drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
214*
215 t( j1, j1 ) = t22
216 t( j2, j2 ) = t11
217*
218 IF( wantq ) THEN
219*
220* Accumulate transformation in the matrix Q.
221*
222 CALL drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
223 END IF
224*
225 ELSE
226*
227* Swapping involves at least one 2-by-2 block.
228*
229* Copy the diagonal block of order N1+N2 to the local array D
230* and compute its norm.
231*
232 nd = n1 + n2
233 CALL dlacpy( 'Full', nd, nd, t( j1, j1 ), ldt, d, ldd )
234 dnorm = dlange( 'Max', nd, nd, d, ldd, work )
235*
236* Compute machine-dependent threshold for test for accepting
237* swap.
238*
239 eps = dlamch( 'P' )
240 smlnum = dlamch( 'S' ) / eps
241 thresh = max( ten*eps*dnorm, smlnum )
242*
243* Solve T11*X - X*T22 = scale*T12 for X.
244*
245 CALL dlasy2( .false., .false., -1, n1, n2, d, ldd,
246 $ d( n1+1, n1+1 ), ldd, d( 1, n1+1 ), ldd, scale, x,
247 $ ldx, xnorm, ierr )
248*
249* Swap the adjacent diagonal blocks.
250*
251 k = n1 + n1 + n2 - 3
252 GO TO ( 10, 20, 30 )k
253*
254 10 CONTINUE
255*
256* N1 = 1, N2 = 2: generate elementary reflector H so that:
257*
258* ( scale, X11, X12 ) H = ( 0, 0, * )
259*
260 u( 1 ) = scale
261 u( 2 ) = x( 1, 1 )
262 u( 3 ) = x( 1, 2 )
263 CALL dlarfg( 3, u( 3 ), u, 1, tau )
264 u( 3 ) = one
265 t11 = t( j1, j1 )
266*
267* Perform swap provisionally on diagonal block in D.
268*
269 CALL dlarfx( 'L', 3, 3, u, tau, d, ldd, work )
270 CALL dlarfx( 'R', 3, 3, u, tau, d, ldd, work )
271*
272* Test whether to reject swap.
273*
274 IF( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,
275 $ 3 )-t11 ) ).GT.thresh )GO TO 50
276*
277* Accept swap: apply transformation to the entire matrix T.
278*
279 CALL dlarfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work )
280 CALL dlarfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work )
281*
282 t( j3, j1 ) = zero
283 t( j3, j2 ) = zero
284 t( j3, j3 ) = t11
285*
286 IF( wantq ) THEN
287*
288* Accumulate transformation in the matrix Q.
289*
290 CALL dlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
291 END IF
292 GO TO 40
293*
294 20 CONTINUE
295*
296* N1 = 2, N2 = 1: generate elementary reflector H so that:
297*
298* H ( -X11 ) = ( * )
299* ( -X21 ) = ( 0 )
300* ( scale ) = ( 0 )
301*
302 u( 1 ) = -x( 1, 1 )
303 u( 2 ) = -x( 2, 1 )
304 u( 3 ) = scale
305 CALL dlarfg( 3, u( 1 ), u( 2 ), 1, tau )
306 u( 1 ) = one
307 t33 = t( j3, j3 )
308*
309* Perform swap provisionally on diagonal block in D.
310*
311 CALL dlarfx( 'L', 3, 3, u, tau, d, ldd, work )
312 CALL dlarfx( 'R', 3, 3, u, tau, d, ldd, work )
313*
314* Test whether to reject swap.
315*
316 IF( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,
317 $ 1 )-t33 ) ).GT.thresh )GO TO 50
318*
319* Accept swap: apply transformation to the entire matrix T.
320*
321 CALL dlarfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work )
322 CALL dlarfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work )
323*
324 t( j1, j1 ) = t33
325 t( j2, j1 ) = zero
326 t( j3, j1 ) = zero
327*
328 IF( wantq ) THEN
329*
330* Accumulate transformation in the matrix Q.
331*
332 CALL dlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work )
333 END IF
334 GO TO 40
335*
336 30 CONTINUE
337*
338* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
339* that:
340*
341* H(2) H(1) ( -X11 -X12 ) = ( * * )
342* ( -X21 -X22 ) ( 0 * )
343* ( scale 0 ) ( 0 0 )
344* ( 0 scale ) ( 0 0 )
345*
346 u1( 1 ) = -x( 1, 1 )
347 u1( 2 ) = -x( 2, 1 )
348 u1( 3 ) = scale
349 CALL dlarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 )
350 u1( 1 ) = one
351*
352 temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) )
353 u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 )
354 u2( 2 ) = -temp*u1( 3 )
355 u2( 3 ) = scale
356 CALL dlarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 )
357 u2( 1 ) = one
358*
359* Perform swap provisionally on diagonal block in D.
360*
361 CALL dlarfx( 'L', 3, 4, u1, tau1, d, ldd, work )
362 CALL dlarfx( 'R', 4, 3, u1, tau1, d, ldd, work )
363 CALL dlarfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work )
364 CALL dlarfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work )
365*
366* Test whether to reject swap.
367*
368 IF( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),
369 $ abs( d( 4, 2 ) ) ).GT.thresh )GO TO 50
370*
371* Accept swap: apply transformation to the entire matrix T.
372*
373 CALL dlarfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work )
374 CALL dlarfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work )
375 CALL dlarfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work )
376 CALL dlarfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work )
377*
378 t( j3, j1 ) = zero
379 t( j3, j2 ) = zero
380 t( j4, j1 ) = zero
381 t( j4, j2 ) = zero
382*
383 IF( wantq ) THEN
384*
385* Accumulate transformation in the matrix Q.
386*
387 CALL dlarfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work )
388 CALL dlarfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work )
389 END IF
390*
391 40 CONTINUE
392*
393 IF( n2.EQ.2 ) THEN
394*
395* Standardize new 2-by-2 block T11
396*
397 CALL dlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),
398 $ t( j2, j2 ), wr1, wi1, wr2, wi2, cs, sn )
399 CALL drot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,
400 $ cs, sn )
401 CALL drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn )
402 IF( wantq )
403 $ CALL drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn )
404 END IF
405*
406 IF( n1.EQ.2 ) THEN
407*
408* Standardize new 2-by-2 block T22
409*
410 j3 = j1 + n2
411 j4 = j3 + 1
412 CALL dlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),
413 $ t( j4, j4 ), wr1, wi1, wr2, wi2, cs, sn )
414 IF( j3+2.LE.n )
415 $ CALL drot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),
416 $ ldt, cs, sn )
417 CALL drot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn )
418 IF( wantq )
419 $ CALL drot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn )
420 END IF
421*
422 END IF
423 RETURN
424*
425* Exit with INFO = 1 if swap was rejected.
426*
427 50 CONTINUE
428 info = 1
429 RETURN
430*
431* End of DLAEXC
432*
dlartg
subroutine dlartg(f, g, c, s, r)
DLARTG generates a plane rotation with real cosine and real sine.
Definition dlartg.f90:113
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
dlange
double precision function dlange(norm, m, n, a, lda, work)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlange.f:114
dlarfx
subroutine dlarfx(side, m, n, v, tau, c, ldc, work)
DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the ...
Definition dlarfx.f:120
dlanv2
subroutine dlanv2(a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
Definition dlanv2.f:127
dlasy2
subroutine dlasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition dlasy2.f:174
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92

◆ dlag2()

subroutine dlag2 ( double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision safmin,
double precision scale1,
double precision scale2,
double precision wr1,
double precision wr2,
double precision wi )

DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow.

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

Purpose:
!>
!> DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
!> problem  A - w B, with scaling as necessary to avoid over-/underflow.
!>
!> The scaling factor  results in a modified eigenvalue equation
!>
!>     s A - w B
!>
!> where  s  is a non-negative scaling factor chosen so that  w,  w B,
!> and  s A  do not overflow and, if possible, do not underflow, either.
!>
Parameters
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA, 2)
!>          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm
!>          is less than 1/SAFMIN.  Entries less than
!>          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= 2.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB, 2)
!>          On entry, the 2 x 2 upper triangular matrix B.  It is
!>          assumed that the one-norm of B is less than 1/SAFMIN.  The
!>          diagonals should be at least sqrt(SAFMIN) times the largest
!>          element of B (in absolute value); if a diagonal is smaller
!>          than that, then  +/- sqrt(SAFMIN) will be used instead of
!>          that diagonal.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= 2.
!>
[in]SAFMIN
!>          SAFMIN is DOUBLE PRECISION
!>          The smallest positive number s.t. 1/SAFMIN does not
!>          overflow.  (This should always be DLAMCH('S') -- it is an
!>          argument in order to avoid having to call DLAMCH frequently.)
!>
[out]SCALE1
!>          SCALE1 is DOUBLE PRECISION
!>          A scaling factor used to avoid over-/underflow in the
!>          eigenvalue equation which defines the first eigenvalue.  If
!>          the eigenvalues are complex, then the eigenvalues are
!>          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the
!>          exponent range of the machine), SCALE1=SCALE2, and SCALE1
!>          will always be positive.  If the eigenvalues are real, then
!>          the first (real) eigenvalue is  WR1 / SCALE1 , but this may
!>          overflow or underflow, and in fact, SCALE1 may be zero or
!>          less than the underflow threshold if the exact eigenvalue
!>          is sufficiently large.
!>
[out]SCALE2
!>          SCALE2 is DOUBLE PRECISION
!>          A scaling factor used to avoid over-/underflow in the
!>          eigenvalue equation which defines the second eigenvalue.  If
!>          the eigenvalues are complex, then SCALE2=SCALE1.  If the
!>          eigenvalues are real, then the second (real) eigenvalue is
!>          WR2 / SCALE2 , but this may overflow or underflow, and in
!>          fact, SCALE2 may be zero or less than the underflow
!>          threshold if the exact eigenvalue is sufficiently large.
!>
[out]WR1
!>          WR1 is DOUBLE PRECISION
!>          If the eigenvalue is real, then WR1 is SCALE1 times the
!>          eigenvalue closest to the (2,2) element of A B**(-1).  If the
!>          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
!>          part of the eigenvalues.
!>
[out]WR2
!>          WR2 is DOUBLE PRECISION
!>          If the eigenvalue is real, then WR2 is SCALE2 times the
!>          other eigenvalue.  If the eigenvalue is complex, then
!>          WR1=WR2 is SCALE1 times the real part of the eigenvalues.
!>
[out]WI
!>          WI is DOUBLE PRECISION
!>          If the eigenvalue is real, then WI is zero.  If the
!>          eigenvalue is complex, then WI is SCALE1 times the imaginary
!>          part of the eigenvalues.  WI will always be non-negative.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file dlag2.f.

156*
157* -- LAPACK auxiliary 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 LDA, LDB
163 DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
164* ..
165* .. Array Arguments ..
166 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 DOUBLE PRECISION ZERO, ONE, TWO
173 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
174 DOUBLE PRECISION HALF
175 parameter( half = one / two )
176 DOUBLE PRECISION FUZZY1
177 parameter( fuzzy1 = one+1.0d-5 )
178* ..
179* .. Local Scalars ..
180 DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
181 $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
182 $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
183 $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
184 $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
185 $ WSCALE, WSIZE, WSMALL
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, max, min, sign, sqrt
189* ..
190* .. Executable Statements ..
191*
192 rtmin = sqrt( safmin )
193 rtmax = one / rtmin
194 safmax = one / safmin
195*
196* Scale A
197*
198 anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),
199 $ abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), safmin )
200 ascale = one / anorm
201 a11 = ascale*a( 1, 1 )
202 a21 = ascale*a( 2, 1 )
203 a12 = ascale*a( 1, 2 )
204 a22 = ascale*a( 2, 2 )
205*
206* Perturb B if necessary to insure non-singularity
207*
208 b11 = b( 1, 1 )
209 b12 = b( 1, 2 )
210 b22 = b( 2, 2 )
211 bmin = rtmin*max( abs( b11 ), abs( b12 ), abs( b22 ), rtmin )
212 IF( abs( b11 ).LT.bmin )
213 $ b11 = sign( bmin, b11 )
214 IF( abs( b22 ).LT.bmin )
215 $ b22 = sign( bmin, b22 )
216*
217* Scale B
218*
219 bnorm = max( abs( b11 ), abs( b12 )+abs( b22 ), safmin )
220 bsize = max( abs( b11 ), abs( b22 ) )
221 bscale = one / bsize
222 b11 = b11*bscale
223 b12 = b12*bscale
224 b22 = b22*bscale
225*
226* Compute larger eigenvalue by method described by C. van Loan
227*
228* ( AS is A shifted by -SHIFT*B )
229*
230 binv11 = one / b11
231 binv22 = one / b22
232 s1 = a11*binv11
233 s2 = a22*binv22
234 IF( abs( s1 ).LE.abs( s2 ) ) THEN
235 as12 = a12 - s1*b12
236 as22 = a22 - s1*b22
237 ss = a21*( binv11*binv22 )
238 abi22 = as22*binv22 - ss*b12
239 pp = half*abi22
240 shift = s1
241 ELSE
242 as12 = a12 - s2*b12
243 as11 = a11 - s2*b11
244 ss = a21*( binv11*binv22 )
245 abi22 = -ss*b12
246 pp = half*( as11*binv11+abi22 )
247 shift = s2
248 END IF
249 qq = ss*as12
250 IF( abs( pp*rtmin ).GE.one ) THEN
251 discr = ( rtmin*pp )**2 + qq*safmin
252 r = sqrt( abs( discr ) )*rtmax
253 ELSE
254 IF( pp**2+abs( qq ).LE.safmin ) THEN
255 discr = ( rtmax*pp )**2 + qq*safmax
256 r = sqrt( abs( discr ) )*rtmin
257 ELSE
258 discr = pp**2 + qq
259 r = sqrt( abs( discr ) )
260 END IF
261 END IF
262*
263* Note: the test of R in the following IF is to cover the case when
264* DISCR is small and negative and is flushed to zero during
265* the calculation of R. On machines which have a consistent
266* flush-to-zero threshold and handle numbers above that
267* threshold correctly, it would not be necessary.
268*
269 IF( discr.GE.zero .OR. r.EQ.zero ) THEN
270 sum = pp + sign( r, pp )
271 diff = pp - sign( r, pp )
272 wbig = shift + sum
273*
274* Compute smaller eigenvalue
275*
276 wsmall = shift + diff
277 IF( half*abs( wbig ).GT.max( abs( wsmall ), safmin ) ) THEN
278 wdet = ( a11*a22-a12*a21 )*( binv11*binv22 )
279 wsmall = wdet / wbig
280 END IF
281*
282* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
283* for WR1.
284*
285 IF( pp.GT.abi22 ) THEN
286 wr1 = min( wbig, wsmall )
287 wr2 = max( wbig, wsmall )
288 ELSE
289 wr1 = max( wbig, wsmall )
290 wr2 = min( wbig, wsmall )
291 END IF
292 wi = zero
293 ELSE
294*
295* Complex eigenvalues
296*
297 wr1 = shift + pp
298 wr2 = wr1
299 wi = r
300 END IF
301*
302* Further scaling to avoid underflow and overflow in computing
303* SCALE1 and overflow in computing w*B.
304*
305* This scale factor (WSCALE) is bounded from above using C1 and C2,
306* and from below using C3 and C4.
307* C1 implements the condition s A must never overflow.
308* C2 implements the condition w B must never overflow.
309* C3, with C2,
310* implement the condition that s A - w B must never overflow.
311* C4 implements the condition s should not underflow.
312* C5 implements the condition max(s,|w|) should be at least 2.
313*
314 c1 = bsize*( safmin*max( one, ascale ) )
315 c2 = safmin*max( one, bnorm )
316 c3 = bsize*safmin
317 IF( ascale.LE.one .AND. bsize.LE.one ) THEN
318 c4 = min( one, ( ascale / safmin )*bsize )
319 ELSE
320 c4 = one
321 END IF
322 IF( ascale.LE.one .OR. bsize.LE.one ) THEN
323 c5 = min( one, ascale*bsize )
324 ELSE
325 c5 = one
326 END IF
327*
328* Scale first eigenvalue
329*
330 wabs = abs( wr1 ) + abs( wi )
331 wsize = max( safmin, c1, fuzzy1*( wabs*c2+c3 ),
332 $ min( c4, half*max( wabs, c5 ) ) )
333 IF( wsize.NE.one ) THEN
334 wscale = one / wsize
335 IF( wsize.GT.one ) THEN
336 scale1 = ( max( ascale, bsize )*wscale )*
337 $ min( ascale, bsize )
338 ELSE
339 scale1 = ( min( ascale, bsize )*wscale )*
340 $ max( ascale, bsize )
341 END IF
342 wr1 = wr1*wscale
343 IF( wi.NE.zero ) THEN
344 wi = wi*wscale
345 wr2 = wr1
346 scale2 = scale1
347 END IF
348 ELSE
349 scale1 = ascale*bsize
350 scale2 = scale1
351 END IF
352*
353* Scale second eigenvalue (if real)
354*
355 IF( wi.EQ.zero ) THEN
356 wsize = max( safmin, c1, fuzzy1*( abs( wr2 )*c2+c3 ),
357 $ min( c4, half*max( abs( wr2 ), c5 ) ) )
358 IF( wsize.NE.one ) THEN
359 wscale = one / wsize
360 IF( wsize.GT.one ) THEN
361 scale2 = ( max( ascale, bsize )*wscale )*
362 $ min( ascale, bsize )
363 ELSE
364 scale2 = ( min( ascale, bsize )*wscale )*
365 $ max( ascale, bsize )
366 END IF
367 wr2 = wr2*wscale
368 ELSE
369 scale2 = ascale*bsize
370 END IF
371 END IF
372*
373* End of DLAG2
374*
375 RETURN

◆ dlag2s()

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

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

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

Purpose:
!>
!> DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE
!> PRECISION matrix, A.
!>
!> RMAX is the overflow for the SINGLE PRECISION arithmetic
!> DLAG2S checks that all the entries of A are between -RMAX and
!> RMAX. If not the conversion is aborted and a flag is raised.
!>
!> This is an auxiliary routine so there is no argument checking.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of lines of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N coefficient matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]SA
!>          SA is REAL array, dimension (LDSA,N)
!>          On exit, if INFO=0, the M-by-N coefficient matrix SA; if
!>          INFO>0, the content of SA is unspecified.
!>
[in]LDSA
!>          LDSA is INTEGER
!>          The leading dimension of the array SA.  LDSA >= max(1,M).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          = 1:  an entry of the matrix A is greater than the SINGLE
!>                PRECISION overflow threshold, in this case, the content
!>                of SA in exit is unspecified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dlag2s.f.

108*
109* -- LAPACK auxiliary 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, LDA, LDSA, M, N
115* ..
116* .. Array Arguments ..
117 REAL SA( LDSA, * )
118 DOUBLE PRECISION A( LDA, * )
119* ..
120*
121* =====================================================================
122*
123* .. Local Scalars ..
124 INTEGER I, J
125 DOUBLE PRECISION RMAX
126* ..
127* .. External Functions ..
128 REAL SLAMCH
129 EXTERNAL slamch
130* ..
131* .. Executable Statements ..
132*
133 rmax = slamch( 'O' )
134 DO 20 j = 1, n
135 DO 10 i = 1, m
136 IF( ( a( i, j ).LT.-rmax ) .OR. ( a( i, j ).GT.rmax ) ) THEN
137 info = 1
138 GO TO 30
139 END IF
140 sa( i, j ) = a( i, j )
141 10 CONTINUE
142 20 CONTINUE
143 info = 0
144 30 CONTINUE
145 RETURN
146*
147* End of DLAG2S
148*
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ dlags2()

subroutine dlags2 ( logical upper,
double precision a1,
double precision a2,
double precision a3,
double precision b1,
double precision b2,
double precision b3,
double precision csu,
double precision snu,
double precision csv,
double precision snv,
double precision csq,
double precision snq )

DLAGS2 computes 2-by-2 orthogonal matrices U, V, and Q, and applies them to matrices A and B such that the rows of the transformed A and B are parallel.

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

Purpose:
!>
!> DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
!> that if ( UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 A2 )*Q = ( x  0  )
!>                             ( 0  A3 )     ( x  x  )
!> and
!>           V**T*B*Q = V**T *( B1 B2 )*Q = ( x  0  )
!>                            ( 0  B3 )     ( x  x  )
!>
!> or if ( .NOT.UPPER ) then
!>
!>           U**T *A*Q = U**T *( A1 0  )*Q = ( x  x  )
!>                             ( A2 A3 )     ( 0  x  )
!> and
!>           V**T*B*Q = V**T*( B1 0  )*Q = ( x  x  )
!>                           ( B2 B3 )     ( 0  x  )
!>
!> The rows of the transformed A and B are parallel, where
!>
!>   U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
!>       ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
!>
!> Z**T denotes the transpose of Z.
!>
!>
Parameters
[in]UPPER
!>          UPPER is LOGICAL
!>          = .TRUE.: the input matrices A and B are upper triangular.
!>          = .FALSE.: the input matrices A and B are lower triangular.
!>
[in]A1
!>          A1 is DOUBLE PRECISION
!>
[in]A2
!>          A2 is DOUBLE PRECISION
!>
[in]A3
!>          A3 is DOUBLE PRECISION
!>          On entry, A1, A2 and A3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix A.
!>
[in]B1
!>          B1 is DOUBLE PRECISION
!>
[in]B2
!>          B2 is DOUBLE PRECISION
!>
[in]B3
!>          B3 is DOUBLE PRECISION
!>          On entry, B1, B2 and B3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix B.
!>
[out]CSU
!>          CSU is DOUBLE PRECISION
!>
[out]SNU
!>          SNU is DOUBLE PRECISION
!>          The desired orthogonal matrix U.
!>
[out]CSV
!>          CSV is DOUBLE PRECISION
!>
[out]SNV
!>          SNV is DOUBLE PRECISION
!>          The desired orthogonal matrix V.
!>
[out]CSQ
!>          CSQ is DOUBLE PRECISION
!>
[out]SNQ
!>          SNQ is DOUBLE PRECISION
!>          The desired orthogonal matrix Q.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file dlags2.f.

152*
153* -- LAPACK auxiliary routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 LOGICAL UPPER
159 DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
160 $ SNU, SNV
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO
167 parameter( zero = 0.0d+0 )
168* ..
169* .. Local Scalars ..
170 DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
171 $ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
172 $ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
173 $ VB11, VB11R, VB12, VB21, VB22, VB22R
174* ..
175* .. External Subroutines ..
176 EXTERNAL dlartg, dlasv2
177* ..
178* .. Intrinsic Functions ..
179 INTRINSIC abs
180* ..
181* .. Executable Statements ..
182*
183 IF( upper ) THEN
184*
185* Input matrices A and B are upper triangular matrices
186*
187* Form matrix C = A*adj(B) = ( a b )
188* ( 0 d )
189*
190 a = a1*b3
191 d = a3*b1
192 b = a2*b1 - a1*b2
193*
194* The SVD of real 2-by-2 triangular C
195*
196* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
197* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
198*
199 CALL dlasv2( a, b, d, s1, s2, snr, csr, snl, csl )
200*
201 IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
202 $ THEN
203*
204* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
205* and (1,2) element of |U|**T *|A| and |V|**T *|B|.
206*
207 ua11r = csl*a1
208 ua12 = csl*a2 + snl*a3
209*
210 vb11r = csr*b1
211 vb12 = csr*b2 + snr*b3
212*
213 aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 )
214 avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 )
215*
216* zero (1,2) elements of U**T *A and V**T *B
217*
218 IF( ( abs( ua11r )+abs( ua12 ) ).NE.zero ) THEN
219 IF( aua12 / ( abs( ua11r )+abs( ua12 ) ).LE.avb12 /
220 $ ( abs( vb11r )+abs( vb12 ) ) ) THEN
221 CALL dlartg( -ua11r, ua12, csq, snq, r )
222 ELSE
223 CALL dlartg( -vb11r, vb12, csq, snq, r )
224 END IF
225 ELSE
226 CALL dlartg( -vb11r, vb12, csq, snq, r )
227 END IF
228*
229 csu = csl
230 snu = -snl
231 csv = csr
232 snv = -snr
233*
234 ELSE
235*
236* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
237* and (2,2) element of |U|**T *|A| and |V|**T *|B|.
238*
239 ua21 = -snl*a1
240 ua22 = -snl*a2 + csl*a3
241*
242 vb21 = -snr*b1
243 vb22 = -snr*b2 + csr*b3
244*
245 aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 )
246 avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 )
247*
248* zero (2,2) elements of U**T*A and V**T*B, and then swap.
249*
250 IF( ( abs( ua21 )+abs( ua22 ) ).NE.zero ) THEN
251 IF( aua22 / ( abs( ua21 )+abs( ua22 ) ).LE.avb22 /
252 $ ( abs( vb21 )+abs( vb22 ) ) ) THEN
253 CALL dlartg( -ua21, ua22, csq, snq, r )
254 ELSE
255 CALL dlartg( -vb21, vb22, csq, snq, r )
256 END IF
257 ELSE
258 CALL dlartg( -vb21, vb22, csq, snq, r )
259 END IF
260*
261 csu = snl
262 snu = csl
263 csv = snr
264 snv = csr
265*
266 END IF
267*
268 ELSE
269*
270* Input matrices A and B are lower triangular matrices
271*
272* Form matrix C = A*adj(B) = ( a 0 )
273* ( c d )
274*
275 a = a1*b3
276 d = a3*b1
277 c = a2*b3 - a3*b2
278*
279* The SVD of real 2-by-2 triangular C
280*
281* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
282* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
283*
284 CALL dlasv2( a, c, d, s1, s2, snr, csr, snl, csl )
285*
286 IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
287 $ THEN
288*
289* Compute the (2,1) and (2,2) elements of U**T *A and V**T *B,
290* and (2,1) element of |U|**T *|A| and |V|**T *|B|.
291*
292 ua21 = -snr*a1 + csr*a2
293 ua22r = csr*a3
294*
295 vb21 = -snl*b1 + csl*b2
296 vb22r = csl*b3
297*
298 aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 )
299 avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 )
300*
301* zero (2,1) elements of U**T *A and V**T *B.
302*
303 IF( ( abs( ua21 )+abs( ua22r ) ).NE.zero ) THEN
304 IF( aua21 / ( abs( ua21 )+abs( ua22r ) ).LE.avb21 /
305 $ ( abs( vb21 )+abs( vb22r ) ) ) THEN
306 CALL dlartg( ua22r, ua21, csq, snq, r )
307 ELSE
308 CALL dlartg( vb22r, vb21, csq, snq, r )
309 END IF
310 ELSE
311 CALL dlartg( vb22r, vb21, csq, snq, r )
312 END IF
313*
314 csu = csr
315 snu = -snr
316 csv = csl
317 snv = -snl
318*
319 ELSE
320*
321* Compute the (1,1) and (1,2) elements of U**T *A and V**T *B,
322* and (1,1) element of |U|**T *|A| and |V|**T *|B|.
323*
324 ua11 = csr*a1 + snr*a2
325 ua12 = snr*a3
326*
327 vb11 = csl*b1 + snl*b2
328 vb12 = snl*b3
329*
330 aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 )
331 avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 )
332*
333* zero (1,1) elements of U**T*A and V**T*B, and then swap.
334*
335 IF( ( abs( ua11 )+abs( ua12 ) ).NE.zero ) THEN
336 IF( aua11 / ( abs( ua11 )+abs( ua12 ) ).LE.avb11 /
337 $ ( abs( vb11 )+abs( vb12 ) ) ) THEN
338 CALL dlartg( ua12, ua11, csq, snq, r )
339 ELSE
340 CALL dlartg( vb12, vb11, csq, snq, r )
341 END IF
342 ELSE
343 CALL dlartg( vb12, vb11, csq, snq, r )
344 END IF
345*
346 csu = snr
347 snu = csr
348 csv = snl
349 snv = csl
350*
351 END IF
352*
353 END IF
354*
355 RETURN
356*
357* End of DLAGS2
358*
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

◆ dlagtm()

subroutine dlagtm ( character trans,
integer n,
integer nrhs,
double precision alpha,
double precision, dimension( * ) dl,
double precision, dimension( * ) d,
double precision, dimension( * ) du,
double precision, dimension( ldx, * ) x,
integer ldx,
double precision beta,
double precision, dimension( ldb, * ) b,
integer ldb )

DLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1.

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

Purpose:
!>
!> DLAGTM performs a matrix-vector product of the form
!>
!>    B := alpha * A * X + beta * B
!>
!> where A is a tridiagonal matrix of order N, B and X are N by NRHS
!> matrices, and alpha and beta are real scalars, each of which may be
!> 0., 1., or -1.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  No transpose, B := alpha * A * X + beta * B
!>          = 'T':  Transpose,    B := alpha * A'* X + beta * B
!>          = 'C':  Conjugate transpose = Transpose
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]DL
!>          DL is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of T.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of T.
!>
[in]DU
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of T.
!>
[in]X
!>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the N by NRHS matrix B.
!>          On exit, B is overwritten by the matrix expression
!>          B := alpha * A * X + beta * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(N,1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 143 of file dlagtm.f.

145*
146* -- LAPACK auxiliary 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 CHARACTER TRANS
152 INTEGER LDB, LDX, N, NRHS
153 DOUBLE PRECISION ALPHA, BETA
154* ..
155* .. Array Arguments ..
156 DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ),
157 $ X( LDX, * )
158* ..
159*
160* =====================================================================
161*
162* .. Parameters ..
163 DOUBLE PRECISION ONE, ZERO
164 parameter( one = 1.0d+0, zero = 0.0d+0 )
165* ..
166* .. Local Scalars ..
167 INTEGER I, J
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. Executable Statements ..
174*
175 IF( n.EQ.0 )
176 $ RETURN
177*
178* Multiply B by BETA if BETA.NE.1.
179*
180 IF( beta.EQ.zero ) THEN
181 DO 20 j = 1, nrhs
182 DO 10 i = 1, n
183 b( i, j ) = zero
184 10 CONTINUE
185 20 CONTINUE
186 ELSE IF( beta.EQ.-one ) THEN
187 DO 40 j = 1, nrhs
188 DO 30 i = 1, n
189 b( i, j ) = -b( i, j )
190 30 CONTINUE
191 40 CONTINUE
192 END IF
193*
194 IF( alpha.EQ.one ) THEN
195 IF( lsame( trans, 'N' ) ) THEN
196*
197* Compute B := B + A*X
198*
199 DO 60 j = 1, nrhs
200 IF( n.EQ.1 ) THEN
201 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
202 ELSE
203 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
204 $ du( 1 )*x( 2, j )
205 b( n, j ) = b( n, j ) + dl( n-1 )*x( n-1, j ) +
206 $ d( n )*x( n, j )
207 DO 50 i = 2, n - 1
208 b( i, j ) = b( i, j ) + dl( i-1 )*x( i-1, j ) +
209 $ d( i )*x( i, j ) + du( i )*x( i+1, j )
210 50 CONTINUE
211 END IF
212 60 CONTINUE
213 ELSE
214*
215* Compute B := B + A**T*X
216*
217 DO 80 j = 1, nrhs
218 IF( n.EQ.1 ) THEN
219 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
220 ELSE
221 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
222 $ dl( 1 )*x( 2, j )
223 b( n, j ) = b( n, j ) + du( n-1 )*x( n-1, j ) +
224 $ d( n )*x( n, j )
225 DO 70 i = 2, n - 1
226 b( i, j ) = b( i, j ) + du( i-1 )*x( i-1, j ) +
227 $ d( i )*x( i, j ) + dl( i )*x( i+1, j )
228 70 CONTINUE
229 END IF
230 80 CONTINUE
231 END IF
232 ELSE IF( alpha.EQ.-one ) THEN
233 IF( lsame( trans, 'N' ) ) THEN
234*
235* Compute B := B - A*X
236*
237 DO 100 j = 1, nrhs
238 IF( n.EQ.1 ) THEN
239 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
240 ELSE
241 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
242 $ du( 1 )*x( 2, j )
243 b( n, j ) = b( n, j ) - dl( n-1 )*x( n-1, j ) -
244 $ d( n )*x( n, j )
245 DO 90 i = 2, n - 1
246 b( i, j ) = b( i, j ) - dl( i-1 )*x( i-1, j ) -
247 $ d( i )*x( i, j ) - du( i )*x( i+1, j )
248 90 CONTINUE
249 END IF
250 100 CONTINUE
251 ELSE
252*
253* Compute B := B - A**T*X
254*
255 DO 120 j = 1, nrhs
256 IF( n.EQ.1 ) THEN
257 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
258 ELSE
259 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
260 $ dl( 1 )*x( 2, j )
261 b( n, j ) = b( n, j ) - du( n-1 )*x( n-1, j ) -
262 $ d( n )*x( n, j )
263 DO 110 i = 2, n - 1
264 b( i, j ) = b( i, j ) - du( i-1 )*x( i-1, j ) -
265 $ d( i )*x( i, j ) - dl( i )*x( i+1, j )
266 110 CONTINUE
267 END IF
268 120 CONTINUE
269 END IF
270 END IF
271 RETURN
272*
273* End of DLAGTM
274*
alpha
#define alpha
Definition eval.h:35
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53

◆ dlagv2()

subroutine dlagv2 ( double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( 2 ) alphar,
double precision, dimension( 2 ) alphai,
double precision, dimension( 2 ) beta,
double precision csl,
double precision snl,
double precision csr,
double precision snr )

DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular.

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

Purpose:
!>
!> DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
!> matrix pencil (A,B) where B is upper triangular. This routine
!> computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
!> SNR such that
!>
!> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
!>    types), then
!>
!>    [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!>    [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!>
!>    [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!>    [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],
!>
!> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
!>    then
!>
!>    [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!>    [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!>
!>    [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!>    [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]
!>
!>    where b11 >= b22 > 0.
!>
!>
Parameters
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA, 2)
!>          On entry, the 2 x 2 matrix A.
!>          On exit, A is overwritten by the ``A-part'' of the
!>          generalized Schur form.
!>
[in]LDA
!>          LDA is INTEGER
!>          THe leading dimension of the array A.  LDA >= 2.
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB, 2)
!>          On entry, the upper triangular 2 x 2 matrix B.
!>          On exit, B is overwritten by the ``B-part'' of the
!>          generalized Schur form.
!>
[in]LDB
!>          LDB is INTEGER
!>          THe leading dimension of the array B.  LDB >= 2.
!>
[out]ALPHAR
!>          ALPHAR is DOUBLE PRECISION array, dimension (2)
!>
[out]ALPHAI
!>          ALPHAI is DOUBLE PRECISION array, dimension (2)
!>
[out]BETA
!>          BETA is DOUBLE PRECISION array, dimension (2)
!>          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
!>          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may
!>          be zero.
!>
[out]CSL
!>          CSL is DOUBLE PRECISION
!>          The cosine of the left rotation matrix.
!>
[out]SNL
!>          SNL is DOUBLE PRECISION
!>          The sine of the left rotation matrix.
!>
[out]CSR
!>          CSR is DOUBLE PRECISION
!>          The cosine of the right rotation matrix.
!>
[out]SNR
!>          SNR is DOUBLE PRECISION
!>          The sine of the right rotation matrix.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA

Definition at line 155 of file dlagv2.f.

157*
158* -- LAPACK auxiliary routine --
159* -- LAPACK is a software package provided by Univ. of Tennessee, --
160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162* .. Scalar Arguments ..
163 INTEGER LDA, LDB
164 DOUBLE PRECISION CSL, CSR, SNL, SNR
165* ..
166* .. Array Arguments ..
167 DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
168 $ B( LDB, * ), BETA( 2 )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ZERO, ONE
175 parameter( zero = 0.0d+0, one = 1.0d+0 )
176* ..
177* .. Local Scalars ..
178 DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
179 $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
180 $ WR2
181* ..
182* .. External Subroutines ..
183 EXTERNAL dlag2, dlartg, dlasv2, drot
184* ..
185* .. External Functions ..
186 DOUBLE PRECISION DLAMCH, DLAPY2
187 EXTERNAL dlamch, dlapy2
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC abs, max
191* ..
192* .. Executable Statements ..
193*
194 safmin = dlamch( 'S' )
195 ulp = dlamch( 'P' )
196*
197* Scale A
198*
199 anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),
200 $ abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), safmin )
201 ascale = one / anorm
202 a( 1, 1 ) = ascale*a( 1, 1 )
203 a( 1, 2 ) = ascale*a( 1, 2 )
204 a( 2, 1 ) = ascale*a( 2, 1 )
205 a( 2, 2 ) = ascale*a( 2, 2 )
206*
207* Scale B
208*
209 bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),
210 $ safmin )
211 bscale = one / bnorm
212 b( 1, 1 ) = bscale*b( 1, 1 )
213 b( 1, 2 ) = bscale*b( 1, 2 )
214 b( 2, 2 ) = bscale*b( 2, 2 )
215*
216* Check if A can be deflated
217*
218 IF( abs( a( 2, 1 ) ).LE.ulp ) THEN
219 csl = one
220 snl = zero
221 csr = one
222 snr = zero
223 a( 2, 1 ) = zero
224 b( 2, 1 ) = zero
225 wi = zero
226*
227* Check if B is singular
228*
229 ELSE IF( abs( b( 1, 1 ) ).LE.ulp ) THEN
230 CALL dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
231 csr = one
232 snr = zero
233 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
234 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
235 a( 2, 1 ) = zero
236 b( 1, 1 ) = zero
237 b( 2, 1 ) = zero
238 wi = zero
239*
240 ELSE IF( abs( b( 2, 2 ) ).LE.ulp ) THEN
241 CALL dlartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t )
242 snr = -snr
243 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
244 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
245 csl = one
246 snl = zero
247 a( 2, 1 ) = zero
248 b( 2, 1 ) = zero
249 b( 2, 2 ) = zero
250 wi = zero
251*
252 ELSE
253*
254* B is nonsingular, first compute the eigenvalues of (A,B)
255*
256 CALL dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,
257 $ wi )
258*
259 IF( wi.EQ.zero ) THEN
260*
261* two real eigenvalues, compute s*A-w*B
262*
263 h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 )
264 h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 )
265 h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 )
266*
267 rr = dlapy2( h1, h2 )
268 qq = dlapy2( scale1*a( 2, 1 ), h3 )
269*
270 IF( rr.GT.qq ) THEN
271*
272* find right rotation matrix to zero 1,1 element of
273* (sA - wB)
274*
275 CALL dlartg( h2, h1, csr, snr, t )
276*
277 ELSE
278*
279* find right rotation matrix to zero 2,1 element of
280* (sA - wB)
281*
282 CALL dlartg( h3, scale1*a( 2, 1 ), csr, snr, t )
283*
284 END IF
285*
286 snr = -snr
287 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
288 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
289*
290* compute inf norms of A and B
291*
292 h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),
293 $ abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) )
294 h2 = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),
295 $ abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) )
296*
297 IF( ( scale1*h1 ).GE.abs( wr1 )*h2 ) THEN
298*
299* find left rotation matrix Q to zero out B(2,1)
300*
301 CALL dlartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r )
302*
303 ELSE
304*
305* find left rotation matrix Q to zero out A(2,1)
306*
307 CALL dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
308*
309 END IF
310*
311 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
312 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
313*
314 a( 2, 1 ) = zero
315 b( 2, 1 ) = zero
316*
317 ELSE
318*
319* a pair of complex conjugate eigenvalues
320* first compute the SVD of the matrix B
321*
322 CALL dlasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,
323 $ csr, snl, csl )
324*
325* Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and
326* Z is right rotation matrix computed from DLASV2
327*
328 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
329 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
330 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
331 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
332*
333 b( 2, 1 ) = zero
334 b( 1, 2 ) = zero
335*
336 END IF
337*
338 END IF
339*
340* Unscaling
341*
342 a( 1, 1 ) = anorm*a( 1, 1 )
343 a( 2, 1 ) = anorm*a( 2, 1 )
344 a( 1, 2 ) = anorm*a( 1, 2 )
345 a( 2, 2 ) = anorm*a( 2, 2 )
346 b( 1, 1 ) = bnorm*b( 1, 1 )
347 b( 2, 1 ) = bnorm*b( 2, 1 )
348 b( 1, 2 ) = bnorm*b( 1, 2 )
349 b( 2, 2 ) = bnorm*b( 2, 2 )
350*
351 IF( wi.EQ.zero ) THEN
352 alphar( 1 ) = a( 1, 1 )
353 alphar( 2 ) = a( 2, 2 )
354 alphai( 1 ) = zero
355 alphai( 2 ) = zero
356 beta( 1 ) = b( 1, 1 )
357 beta( 2 ) = b( 2, 2 )
358 ELSE
359 alphar( 1 ) = anorm*wr1 / scale1 / bnorm
360 alphai( 1 ) = anorm*wi / scale1 / bnorm
361 alphar( 2 ) = alphar( 1 )
362 alphai( 2 ) = -alphai( 1 )
363 beta( 1 ) = one
364 beta( 2 ) = one
365 END IF
366*
367 RETURN
368*
369* End of DLAGV2
370*
dlag2
subroutine dlag2(a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi)
DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
Definition dlag2.f:156

◆ dlahqr()

subroutine dlahqr ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
integer info )

DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.

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

Purpose:
!>
!>    DLAHQR is an auxiliary routine called by DHSEQR to update the
!>    eigenvalues and Schur decomposition already computed by DHSEQR, by
!>    dealing with the Hessenberg submatrix in rows and columns ILO to
!>    IHI.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>          = .TRUE. : the full Schur form T is required;
!>          = .FALSE.: only eigenvalues are required.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          = .TRUE. : the matrix of Schur vectors Z is required;
!>          = .FALSE.: Schur vectors are not required.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>          It is assumed that H is already upper quasi-triangular in
!>          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
!>          ILO = 1). DLAHQR works primarily with the Hessenberg
!>          submatrix in rows and columns ILO to IHI, but applies
!>          transformations to all of H if WANTT is .TRUE..
!>          1 <= ILO <= max(1,IHI); IHI <= N.
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          On entry, the upper Hessenberg matrix H.
!>          On exit, if INFO is zero and if WANTT is .TRUE., H is upper
!>          quasi-triangular in rows and columns ILO:IHI, with any
!>          2-by-2 diagonal blocks in standard form. If INFO is zero
!>          and WANTT is .FALSE., the contents of H are unspecified on
!>          exit.  The output state of H if INFO is nonzero is given
!>          below under the description of INFO.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H. LDH >= max(1,N).
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (N)
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (N)
!>          The real and imaginary parts, respectively, of the computed
!>          eigenvalues ILO to IHI are stored in the corresponding
!>          elements of WR and WI. If two eigenvalues are computed as a
!>          complex conjugate pair, they are stored in consecutive
!>          elements of WR and WI, say the i-th and (i+1)th, with
!>          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
!>          eigenvalues are stored in the same order as on the diagonal
!>          of the Schur form returned in H, with WR(i) = H(i,i), and, if
!>          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
!>          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>          Specify the rows of Z to which transformations must be
!>          applied if WANTZ is .TRUE..
!>          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
!>          If WANTZ is .TRUE., on entry Z must contain the current
!>          matrix Z of transformations accumulated by DHSEQR, and on
!>          exit Z has been updated; transformations are applied only to
!>          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
!>          If WANTZ is .FALSE., Z is not referenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z. LDZ >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>           = 0:  successful exit
!>           > 0:  If INFO = i, DLAHQR failed to compute all the
!>                  eigenvalues ILO to IHI in a total of 30 iterations
!>                  per eigenvalue; elements i+1:ihi of WR and WI
!>                  contain those eigenvalues which have been
!>                  successfully computed.
!>
!>                  If INFO > 0 and WANTT is .FALSE., then on exit,
!>                  the remaining unconverged eigenvalues are the
!>                  eigenvalues of the upper Hessenberg matrix rows
!>                  and columns ILO through INFO of the final, output
!>                  value of H.
!>
!>                  If INFO > 0 and WANTT is .TRUE., then on exit
!>          (*)       (initial value of H)*U  = U*(final value of H)
!>                  where U is an orthogonal matrix.    The final
!>                  value of H is upper Hessenberg and triangular in
!>                  rows and columns INFO+1 through IHI.
!>
!>                  If INFO > 0 and WANTZ is .TRUE., then on exit
!>                      (final value of Z)  = (initial value of Z)*U
!>                  where U is the orthogonal matrix in (*)
!>                  (regardless of the value of WANTT.)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>     02-96 Based on modifications by
!>     David Day, Sandia National Laboratory, USA
!>
!>     12-04 Further modifications by
!>     Ralph Byers, University of Kansas, USA
!>     This is a modified version of DLAHQR from LAPACK version 3.0.
!>     It is (1) more robust against overflow and underflow and
!>     (2) adopts the more conservative Ahues & Tisseur stopping
!>     criterion (LAWN 122, 1997).
!>

Definition at line 205 of file dlahqr.f.

207 IMPLICIT NONE
208*
209* -- LAPACK auxiliary routine --
210* -- LAPACK is a software package provided by Univ. of Tennessee, --
211* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
212*
213* .. Scalar Arguments ..
214 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
215 LOGICAL WANTT, WANTZ
216* ..
217* .. Array Arguments ..
218 DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
219* ..
220*
221* =========================================================
222*
223* .. Parameters ..
224 DOUBLE PRECISION ZERO, ONE, TWO
225 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
226 DOUBLE PRECISION DAT1, DAT2
227 parameter( dat1 = 3.0d0 / 4.0d0, dat2 = -0.4375d0 )
228 INTEGER KEXSH
229 parameter( kexsh = 10 )
230* ..
231* .. Local Scalars ..
232 DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
233 $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
234 $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
235 $ ULP, V2, V3
236 INTEGER I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ,
237 $ KDEFL
238* ..
239* .. Local Arrays ..
240 DOUBLE PRECISION V( 3 )
241* ..
242* .. External Functions ..
243 DOUBLE PRECISION DLAMCH
244 EXTERNAL dlamch
245* ..
246* .. External Subroutines ..
247 EXTERNAL dcopy, dlabad, dlanv2, dlarfg, drot
248* ..
249* .. Intrinsic Functions ..
250 INTRINSIC abs, dble, max, min, sqrt
251* ..
252* .. Executable Statements ..
253*
254 info = 0
255*
256* Quick return if possible
257*
258 IF( n.EQ.0 )
259 $ RETURN
260 IF( ilo.EQ.ihi ) THEN
261 wr( ilo ) = h( ilo, ilo )
262 wi( ilo ) = zero
263 RETURN
264 END IF
265*
266* ==== clear out the trash ====
267 DO 10 j = ilo, ihi - 3
268 h( j+2, j ) = zero
269 h( j+3, j ) = zero
270 10 CONTINUE
271 IF( ilo.LE.ihi-2 )
272 $ h( ihi, ihi-2 ) = zero
273*
274 nh = ihi - ilo + 1
275 nz = ihiz - iloz + 1
276*
277* Set machine-dependent constants for the stopping criterion.
278*
279 safmin = dlamch( 'SAFE MINIMUM' )
280 safmax = one / safmin
281 CALL dlabad( safmin, safmax )
282 ulp = dlamch( 'PRECISION' )
283 smlnum = safmin*( dble( nh ) / ulp )
284*
285* I1 and I2 are the indices of the first row and last column of H
286* to which transformations must be applied. If eigenvalues only are
287* being computed, I1 and I2 are set inside the main loop.
288*
289 IF( wantt ) THEN
290 i1 = 1
291 i2 = n
292 END IF
293*
294* ITMAX is the total number of QR iterations allowed.
295*
296 itmax = 30 * max( 10, nh )
297*
298* KDEFL counts the number of iterations since a deflation
299*
300 kdefl = 0
301*
302* The main loop begins here. I is the loop index and decreases from
303* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
304* with the active submatrix in rows and columns L to I.
305* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
306* H(L,L-1) is negligible so that the matrix splits.
307*
308 i = ihi
309 20 CONTINUE
310 l = ilo
311 IF( i.LT.ilo )
312 $ GO TO 160
313*
314* Perform QR iterations on rows and columns ILO to I until a
315* submatrix of order 1 or 2 splits off at the bottom because a
316* subdiagonal element has become negligible.
317*
318 DO 140 its = 0, itmax
319*
320* Look for a single small subdiagonal element.
321*
322 DO 30 k = i, l + 1, -1
323 IF( abs( h( k, k-1 ) ).LE.smlnum )
324 $ GO TO 40
325 tst = abs( h( k-1, k-1 ) ) + abs( h( k, k ) )
326 IF( tst.EQ.zero ) THEN
327 IF( k-2.GE.ilo )
328 $ tst = tst + abs( h( k-1, k-2 ) )
329 IF( k+1.LE.ihi )
330 $ tst = tst + abs( h( k+1, k ) )
331 END IF
332* ==== The following is a conservative small subdiagonal
333* . deflation criterion due to Ahues & Tisseur (LAWN 122,
334* . 1997). It has better mathematical foundation and
335* . improves accuracy in some cases. ====
336 IF( abs( h( k, k-1 ) ).LE.ulp*tst ) THEN
337 ab = max( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
338 ba = min( abs( h( k, k-1 ) ), abs( h( k-1, k ) ) )
339 aa = max( abs( h( k, k ) ),
340 $ abs( h( k-1, k-1 )-h( k, k ) ) )
341 bb = min( abs( h( k, k ) ),
342 $ abs( h( k-1, k-1 )-h( k, k ) ) )
343 s = aa + ab
344 IF( ba*( ab / s ).LE.max( smlnum,
345 $ ulp*( bb*( aa / s ) ) ) )GO TO 40
346 END IF
347 30 CONTINUE
348 40 CONTINUE
349 l = k
350 IF( l.GT.ilo ) THEN
351*
352* H(L,L-1) is negligible
353*
354 h( l, l-1 ) = zero
355 END IF
356*
357* Exit from loop if a submatrix of order 1 or 2 has split off.
358*
359 IF( l.GE.i-1 )
360 $ GO TO 150
361 kdefl = kdefl + 1
362*
363* Now the active submatrix is in rows and columns L to I. If
364* eigenvalues only are being computed, only the active submatrix
365* need be transformed.
366*
367 IF( .NOT.wantt ) THEN
368 i1 = l
369 i2 = i
370 END IF
371*
372 IF( mod(kdefl,2*kexsh).EQ.0 ) THEN
373*
374* Exceptional shift.
375*
376 s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
377 h11 = dat1*s + h( i, i )
378 h12 = dat2*s
379 h21 = s
380 h22 = h11
381 ELSE IF( mod(kdefl,kexsh).EQ.0 ) THEN
382*
383* Exceptional shift.
384*
385 s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) )
386 h11 = dat1*s + h( l, l )
387 h12 = dat2*s
388 h21 = s
389 h22 = h11
390 ELSE
391*
392* Prepare to use Francis' double shift
393* (i.e. 2nd degree generalized Rayleigh quotient)
394*
395 h11 = h( i-1, i-1 )
396 h21 = h( i, i-1 )
397 h12 = h( i-1, i )
398 h22 = h( i, i )
399 END IF
400 s = abs( h11 ) + abs( h12 ) + abs( h21 ) + abs( h22 )
401 IF( s.EQ.zero ) THEN
402 rt1r = zero
403 rt1i = zero
404 rt2r = zero
405 rt2i = zero
406 ELSE
407 h11 = h11 / s
408 h21 = h21 / s
409 h12 = h12 / s
410 h22 = h22 / s
411 tr = ( h11+h22 ) / two
412 det = ( h11-tr )*( h22-tr ) - h12*h21
413 rtdisc = sqrt( abs( det ) )
414 IF( det.GE.zero ) THEN
415*
416* ==== complex conjugate shifts ====
417*
418 rt1r = tr*s
419 rt2r = rt1r
420 rt1i = rtdisc*s
421 rt2i = -rt1i
422 ELSE
423*
424* ==== real shifts (use only one of them) ====
425*
426 rt1r = tr + rtdisc
427 rt2r = tr - rtdisc
428 IF( abs( rt1r-h22 ).LE.abs( rt2r-h22 ) ) THEN
429 rt1r = rt1r*s
430 rt2r = rt1r
431 ELSE
432 rt2r = rt2r*s
433 rt1r = rt2r
434 END IF
435 rt1i = zero
436 rt2i = zero
437 END IF
438 END IF
439*
440* Look for two consecutive small subdiagonal elements.
441*
442 DO 50 m = i - 2, l, -1
443* Determine the effect of starting the double-shift QR
444* iteration at row M, and see if this would make H(M,M-1)
445* negligible. (The following uses scaling to avoid
446* overflows and most underflows.)
447*
448 h21s = h( m+1, m )
449 s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s )
450 h21s = h( m+1, m ) / s
451 v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*
452 $ ( ( h( m, m )-rt2r ) / s ) - rt1i*( rt2i / s )
453 v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r )
454 v( 3 ) = h21s*h( m+2, m+1 )
455 s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) )
456 v( 1 ) = v( 1 ) / s
457 v( 2 ) = v( 2 ) / s
458 v( 3 ) = v( 3 ) / s
459 IF( m.EQ.l )
460 $ GO TO 60
461 IF( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) ).LE.
462 $ ulp*abs( v( 1 ) )*( abs( h( m-1, m-1 ) )+abs( h( m,
463 $ m ) )+abs( h( m+1, m+1 ) ) ) )GO TO 60
464 50 CONTINUE
465 60 CONTINUE
466*
467* Double-shift QR step
468*
469 DO 130 k = m, i - 1
470*
471* The first iteration of this loop determines a reflection G
472* from the vector V and applies it from left and right to H,
473* thus creating a nonzero bulge below the subdiagonal.
474*
475* Each subsequent iteration determines a reflection G to
476* restore the Hessenberg form in the (K-1)th column, and thus
477* chases the bulge one step toward the bottom of the active
478* submatrix. NR is the order of G.
479*
480 nr = min( 3, i-k+1 )
481 IF( k.GT.m )
482 $ CALL dcopy( nr, h( k, k-1 ), 1, v, 1 )
483 CALL dlarfg( nr, v( 1 ), v( 2 ), 1, t1 )
484 IF( k.GT.m ) THEN
485 h( k, k-1 ) = v( 1 )
486 h( k+1, k-1 ) = zero
487 IF( k.LT.i-1 )
488 $ h( k+2, k-1 ) = zero
489 ELSE IF( m.GT.l ) THEN
490* ==== Use the following instead of
491* . H( K, K-1 ) = -H( K, K-1 ) to
492* . avoid a bug when v(2) and v(3)
493* . underflow. ====
494 h( k, k-1 ) = h( k, k-1 )*( one-t1 )
495 END IF
496 v2 = v( 2 )
497 t2 = t1*v2
498 IF( nr.EQ.3 ) THEN
499 v3 = v( 3 )
500 t3 = t1*v3
501*
502* Apply G from the left to transform the rows of the matrix
503* in columns K to I2.
504*
505 DO 70 j = k, i2
506 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j )
507 h( k, j ) = h( k, j ) - sum*t1
508 h( k+1, j ) = h( k+1, j ) - sum*t2
509 h( k+2, j ) = h( k+2, j ) - sum*t3
510 70 CONTINUE
511*
512* Apply G from the right to transform the columns of the
513* matrix in rows I1 to min(K+3,I).
514*
515 DO 80 j = i1, min( k+3, i )
516 sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 )
517 h( j, k ) = h( j, k ) - sum*t1
518 h( j, k+1 ) = h( j, k+1 ) - sum*t2
519 h( j, k+2 ) = h( j, k+2 ) - sum*t3
520 80 CONTINUE
521*
522 IF( wantz ) THEN
523*
524* Accumulate transformations in the matrix Z
525*
526 DO 90 j = iloz, ihiz
527 sum = z( j, k ) + v2*z( j, k+1 ) + v3*z( j, k+2 )
528 z( j, k ) = z( j, k ) - sum*t1
529 z( j, k+1 ) = z( j, k+1 ) - sum*t2
530 z( j, k+2 ) = z( j, k+2 ) - sum*t3
531 90 CONTINUE
532 END IF
533 ELSE IF( nr.EQ.2 ) THEN
534*
535* Apply G from the left to transform the rows of the matrix
536* in columns K to I2.
537*
538 DO 100 j = k, i2
539 sum = h( k, j ) + v2*h( k+1, j )
540 h( k, j ) = h( k, j ) - sum*t1
541 h( k+1, j ) = h( k+1, j ) - sum*t2
542 100 CONTINUE
543*
544* Apply G from the right to transform the columns of the
545* matrix in rows I1 to min(K+3,I).
546*
547 DO 110 j = i1, i
548 sum = h( j, k ) + v2*h( j, k+1 )
549 h( j, k ) = h( j, k ) - sum*t1
550 h( j, k+1 ) = h( j, k+1 ) - sum*t2
551 110 CONTINUE
552*
553 IF( wantz ) THEN
554*
555* Accumulate transformations in the matrix Z
556*
557 DO 120 j = iloz, ihiz
558 sum = z( j, k ) + v2*z( j, k+1 )
559 z( j, k ) = z( j, k ) - sum*t1
560 z( j, k+1 ) = z( j, k+1 ) - sum*t2
561 120 CONTINUE
562 END IF
563 END IF
564 130 CONTINUE
565*
566 140 CONTINUE
567*
568* Failure to converge in remaining number of iterations
569*
570 info = i
571 RETURN
572*
573 150 CONTINUE
574*
575 IF( l.EQ.i ) THEN
576*
577* H(I,I-1) is negligible: one eigenvalue has converged.
578*
579 wr( i ) = h( i, i )
580 wi( i ) = zero
581 ELSE IF( l.EQ.i-1 ) THEN
582*
583* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
584*
585* Transform the 2-by-2 submatrix to standard Schur form,
586* and compute and store the eigenvalues.
587*
588 CALL dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),
589 $ h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ),
590 $ cs, sn )
591*
592 IF( wantt ) THEN
593*
594* Apply the transformation to the rest of H.
595*
596 IF( i2.GT.i )
597 $ CALL drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,
598 $ cs, sn )
599 CALL drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn )
600 END IF
601 IF( wantz ) THEN
602*
603* Apply the transformation to Z.
604*
605 CALL drot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn )
606 END IF
607 END IF
608* reset deflation counter
609 kdefl = 0
610*
611* return to start of the main loop with new value of I.
612*
613 i = l - 1
614 GO TO 20
615*
616 160 CONTINUE
617 RETURN
618*
619* End of DLAHQR
620*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74

◆ dlahr2()

subroutine dlahr2 ( integer n,
integer k,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( nb ) tau,
double precision, dimension( ldt, nb ) t,
integer ldt,
double precision, dimension( ldy, nb ) y,
integer ldy )

DLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.

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

Purpose:
!>
!> DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
!> matrix A so that elements below the k-th subdiagonal are zero. The
!> reduction is performed by an orthogonal similarity transformation
!> Q**T * A * Q. The routine returns the matrices V and T which determine
!> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T.
!>
!> This is an auxiliary routine called by DGEHRD.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.
!>
[in]K
!>          K is INTEGER
!>          The offset for the reduction. Elements below the k-th
!>          subdiagonal in the first NB columns are reduced to zero.
!>          K < N.
!>
[in]NB
!>          NB is INTEGER
!>          The number of columns to be reduced.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N-K+1)
!>          On entry, the n-by-(n-k+1) general matrix A.
!>          On exit, the elements on and above the k-th subdiagonal in
!>          the first NB columns are overwritten with the corresponding
!>          elements of the reduced matrix; the elements below the k-th
!>          subdiagonal, with the array TAU, represent the matrix Q as a
!>          product of elementary reflectors. The other columns of A are
!>          unchanged. See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,NB)
!>          The upper triangular matrix T.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[out]Y
!>          Y is DOUBLE PRECISION array, dimension (LDY,NB)
!>          The n-by-nb matrix Y.
!>
[in]LDY
!>          LDY is INTEGER
!>          The leading dimension of the array Y. LDY >= N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrix Q is represented as a product of nb elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
!>  A(i+k+1:n,i), and tau in TAU(i).
!>
!>  The elements of the vectors v together form the (n-k+1)-by-nb matrix
!>  V which is needed, with T and Y, to apply the transformation to the
!>  unreduced part of the matrix, using an update of the form:
!>  A := (I - V*T*V**T) * (A - Y*V**T).
!>
!>  The contents of A on exit are illustrated by the following example
!>  with n = 7, k = 3 and nb = 2:
!>
!>     ( a   a   a   a   a )
!>     ( a   a   a   a   a )
!>     ( a   a   a   a   a )
!>     ( h   h   a   a   a )
!>     ( v1  h   a   a   a )
!>     ( v1  v2  a   a   a )
!>     ( v1  v2  a   a   a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>
!>  This subroutine is a slight modification of LAPACK-3.0's DLAHRD
!>  incorporating improvements proposed by Quintana-Orti and Van de
!>  Gejin. Note that the entries of A(1:K,2:NB) differ from those
!>  returned by the original LAPACK-3.0's DLAHRD routine. (This
!>  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
!>
References:
Gregorio Quintana-Orti and Robert van de Geijn, "Improving the performance of reduction to Hessenberg form," ACM Transactions on Mathematical Software, 32(2):180-194, June 2006.

Definition at line 180 of file dlahr2.f.

181*
182* -- LAPACK auxiliary routine --
183* -- LAPACK is a software package provided by Univ. of Tennessee, --
184* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
185*
186* .. Scalar Arguments ..
187 INTEGER K, LDA, LDT, LDY, N, NB
188* ..
189* .. Array Arguments ..
190 DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
191 $ Y( LDY, NB )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 DOUBLE PRECISION ZERO, ONE
198 parameter( zero = 0.0d+0,
199 $ one = 1.0d+0 )
200* ..
201* .. Local Scalars ..
202 INTEGER I
203 DOUBLE PRECISION EI
204* ..
205* .. External Subroutines ..
206 EXTERNAL daxpy, dcopy, dgemm, dgemv, dlacpy,
207 $ dlarfg, dscal, dtrmm, dtrmv
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC min
211* ..
212* .. Executable Statements ..
213*
214* Quick return if possible
215*
216 IF( n.LE.1 )
217 $ RETURN
218*
219 DO 10 i = 1, nb
220 IF( i.GT.1 ) THEN
221*
222* Update A(K+1:N,I)
223*
224* Update I-th column of A - Y * V**T
225*
226 CALL dgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,
227 $ a( k+i-1, 1 ), lda, one, a( k+1, i ), 1 )
228*
229* Apply I - V * T**T * V**T to this column (call it b) from the
230* left, using the last column of T as workspace
231*
232* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
233* ( V2 ) ( b2 )
234*
235* where V1 is unit lower triangular
236*
237* w := V1**T * b1
238*
239 CALL dcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
240 CALL dtrmv( 'Lower', 'Transpose', 'UNIT',
241 $ i-1, a( k+1, 1 ),
242 $ lda, t( 1, nb ), 1 )
243*
244* w := w + V2**T * b2
245*
246 CALL dgemv( 'Transpose', n-k-i+1, i-1,
247 $ one, a( k+i, 1 ),
248 $ lda, a( k+i, i ), 1, one, t( 1, nb ), 1 )
249*
250* w := T**T * w
251*
252 CALL dtrmv( 'Upper', 'Transpose', 'NON-UNIT',
253 $ i-1, t, ldt,
254 $ t( 1, nb ), 1 )
255*
256* b2 := b2 - V2*w
257*
258 CALL dgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,
259 $ a( k+i, 1 ),
260 $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 )
261*
262* b1 := b1 - V1*w
263*
264 CALL dtrmv( 'Lower', 'NO TRANSPOSE',
265 $ 'UNIT', i-1,
266 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
267 CALL daxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 )
268*
269 a( k+i-1, i-1 ) = ei
270 END IF
271*
272* Generate the elementary reflector H(I) to annihilate
273* A(K+I+1:N,I)
274*
275 CALL dlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,
276 $ tau( i ) )
277 ei = a( k+i, i )
278 a( k+i, i ) = one
279*
280* Compute Y(K+1:N,I)
281*
282 CALL dgemv( 'NO TRANSPOSE', n-k, n-k-i+1,
283 $ one, a( k+1, i+1 ),
284 $ lda, a( k+i, i ), 1, zero, y( k+1, i ), 1 )
285 CALL dgemv( 'Transpose', n-k-i+1, i-1,
286 $ one, a( k+i, 1 ), lda,
287 $ a( k+i, i ), 1, zero, t( 1, i ), 1 )
288 CALL dgemv( 'NO TRANSPOSE', n-k, i-1, -one,
289 $ y( k+1, 1 ), ldy,
290 $ t( 1, i ), 1, one, y( k+1, i ), 1 )
291 CALL dscal( n-k, tau( i ), y( k+1, i ), 1 )
292*
293* Compute T(1:I,I)
294*
295 CALL dscal( i-1, -tau( i ), t( 1, i ), 1 )
296 CALL dtrmv( 'Upper', 'No Transpose', 'NON-UNIT',
297 $ i-1, t, ldt,
298 $ t( 1, i ), 1 )
299 t( i, i ) = tau( i )
300*
301 10 CONTINUE
302 a( k+nb, nb ) = ei
303*
304* Compute Y(1:K,1:NB)
305*
306 CALL dlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy )
307 CALL dtrmm( 'RIGHT', 'Lower', 'NO TRANSPOSE',
308 $ 'UNIT', k, nb,
309 $ one, a( k+1, 1 ), lda, y, ldy )
310 IF( n.GT.k+nb )
311 $ CALL dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,
312 $ nb, n-k-nb, one,
313 $ a( 1, 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,
314 $ ldy )
315 CALL dtrmm( 'RIGHT', 'Upper', 'NO TRANSPOSE',
316 $ 'NON-UNIT', k, nb,
317 $ one, t, ldt, y, ldy )
318*
319 RETURN
320*
321* End of DLAHR2
322*
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89
dtrmv
subroutine dtrmv(uplo, trans, diag, n, a, lda, x, incx)
DTRMV
Definition dtrmv.f:147
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
dtrmm
subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
DTRMM
Definition dtrmm.f:177

◆ dlahrd()

subroutine dlahrd ( integer n,
integer k,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( nb ) tau,
double precision, dimension( ldt, nb ) t,
integer ldt,
double precision, dimension( ldy, nb ) y,
integer ldy )

DLAHRD reduces the first nb columns of a general rectangular matrix A so that elements below the k-th subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine DLAHR2.
!>
!> DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
!> matrix A so that elements below the k-th subdiagonal are zero. The
!> reduction is performed by an orthogonal similarity transformation
!> Q**T * A * Q. The routine returns the matrices V and T which determine
!> Q as a block reflector I - V*T*V**T, and also the matrix Y = A * V * T.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.
!>
[in]K
!>          K is INTEGER
!>          The offset for the reduction. Elements below the k-th
!>          subdiagonal in the first NB columns are reduced to zero.
!>
[in]NB
!>          NB is INTEGER
!>          The number of columns to be reduced.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N-K+1)
!>          On entry, the n-by-(n-k+1) general matrix A.
!>          On exit, the elements on and above the k-th subdiagonal in
!>          the first NB columns are overwritten with the corresponding
!>          elements of the reduced matrix; the elements below the k-th
!>          subdiagonal, with the array TAU, represent the matrix Q as a
!>          product of elementary reflectors. The other columns of A are
!>          unchanged. See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,NB)
!>          The upper triangular matrix T.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!>
[out]Y
!>          Y is DOUBLE PRECISION array, dimension (LDY,NB)
!>          The n-by-nb matrix Y.
!>
[in]LDY
!>          LDY is INTEGER
!>          The leading dimension of the array Y. LDY >= N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrix Q is represented as a product of nb elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
!>  A(i+k+1:n,i), and tau in TAU(i).
!>
!>  The elements of the vectors v together form the (n-k+1)-by-nb matrix
!>  V which is needed, with T and Y, to apply the transformation to the
!>  unreduced part of the matrix, using an update of the form:
!>  A := (I - V*T*V**T) * (A - Y*V**T).
!>
!>  The contents of A on exit are illustrated by the following example
!>  with n = 7, k = 3 and nb = 2:
!>
!>     ( a   h   a   a   a )
!>     ( a   h   a   a   a )
!>     ( a   h   a   a   a )
!>     ( h   h   a   a   a )
!>     ( v1  h   a   a   a )
!>     ( v1  v2  a   a   a )
!>     ( v1  v2  a   a   a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>

Definition at line 166 of file dlahrd.f.

167*
168* -- LAPACK auxiliary routine --
169* -- LAPACK is a software package provided by Univ. of Tennessee, --
170* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171*
172* .. Scalar Arguments ..
173 INTEGER K, LDA, LDT, LDY, N, NB
174* ..
175* .. Array Arguments ..
176 DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
177 $ Y( LDY, NB )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO, ONE
184 parameter( zero = 0.0d+0, one = 1.0d+0 )
185* ..
186* .. Local Scalars ..
187 INTEGER I
188 DOUBLE PRECISION EI
189* ..
190* .. External Subroutines ..
191 EXTERNAL daxpy, dcopy, dgemv, dlarfg, dscal, dtrmv
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC min
195* ..
196* .. Executable Statements ..
197*
198* Quick return if possible
199*
200 IF( n.LE.1 )
201 $ RETURN
202*
203 DO 10 i = 1, nb
204 IF( i.GT.1 ) THEN
205*
206* Update A(1:n,i)
207*
208* Compute i-th column of A - Y * V**T
209*
210 CALL dgemv( 'No transpose', n, i-1, -one, y, ldy,
211 $ a( k+i-1, 1 ), lda, one, a( 1, i ), 1 )
212*
213* Apply I - V * T**T * V**T to this column (call it b) from the
214* left, using the last column of T as workspace
215*
216* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
217* ( V2 ) ( b2 )
218*
219* where V1 is unit lower triangular
220*
221* w := V1**T * b1
222*
223 CALL dcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
224 CALL dtrmv( 'Lower', 'Transpose', 'Unit', i-1, a( k+1, 1 ),
225 $ lda, t( 1, nb ), 1 )
226*
227* w := w + V2**T *b2
228*
229 CALL dgemv( 'Transpose', n-k-i+1, i-1, one, a( k+i, 1 ),
230 $ lda, a( k+i, i ), 1, one, t( 1, nb ), 1 )
231*
232* w := T**T *w
233*
234 CALL dtrmv( 'Upper', 'Transpose', 'Non-unit', i-1, t, ldt,
235 $ t( 1, nb ), 1 )
236*
237* b2 := b2 - V2*w
238*
239 CALL dgemv( 'No transpose', n-k-i+1, i-1, -one, a( k+i, 1 ),
240 $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 )
241*
242* b1 := b1 - V1*w
243*
244 CALL dtrmv( 'Lower', 'No transpose', 'Unit', i-1,
245 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
246 CALL daxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 )
247*
248 a( k+i-1, i-1 ) = ei
249 END IF
250*
251* Generate the elementary reflector H(i) to annihilate
252* A(k+i+1:n,i)
253*
254 CALL dlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,
255 $ tau( i ) )
256 ei = a( k+i, i )
257 a( k+i, i ) = one
258*
259* Compute Y(1:n,i)
260*
261 CALL dgemv( 'No transpose', n, n-k-i+1, one, a( 1, i+1 ), lda,
262 $ a( k+i, i ), 1, zero, y( 1, i ), 1 )
263 CALL dgemv( 'Transpose', n-k-i+1, i-1, one, a( k+i, 1 ), lda,
264 $ a( k+i, i ), 1, zero, t( 1, i ), 1 )
265 CALL dgemv( 'No transpose', n, i-1, -one, y, ldy, t( 1, i ), 1,
266 $ one, y( 1, i ), 1 )
267 CALL dscal( n, tau( i ), y( 1, i ), 1 )
268*
269* Compute T(1:i,i)
270*
271 CALL dscal( i-1, -tau( i ), t( 1, i ), 1 )
272 CALL dtrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t, ldt,
273 $ t( 1, i ), 1 )
274 t( i, i ) = tau( i )
275*
276 10 CONTINUE
277 a( k+nb, nb ) = ei
278*
279 RETURN
280*
281* End of DLAHRD
282*

◆ dlaic1()

subroutine dlaic1 ( integer job,
integer j,
double precision, dimension( j ) x,
double precision sest,
double precision, dimension( j ) w,
double precision gamma,
double precision sestpr,
double precision s,
double precision c )

DLAIC1 applies one step of incremental condition estimation.

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

Purpose:
!>
!> DLAIC1 applies one step of incremental condition estimation in
!> its simplest version:
!>
!> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
!> lower triangular matrix L, such that
!>          twonorm(L*x) = sest
!> Then DLAIC1 computes sestpr, s, c such that
!> the vector
!>                 [ s*x ]
!>          xhat = [  c  ]
!> is an approximate singular vector of
!>                 [ L       0  ]
!>          Lhat = [ w**T gamma ]
!> in the sense that
!>          twonorm(Lhat*xhat) = sestpr.
!>
!> Depending on JOB, an estimate for the largest or smallest singular
!> value is computed.
!>
!> Note that [s c]**T and sestpr**2 is an eigenpair of the system
!>
!>     diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]
!>                                           [ gamma ]
!>
!> where  alpha =  x**T*w.
!>
Parameters
[in]JOB
!>          JOB is INTEGER
!>          = 1: an estimate for the largest singular value is computed.
!>          = 2: an estimate for the smallest singular value is computed.
!>
[in]J
!>          J is INTEGER
!>          Length of X and W
!>
[in]X
!>          X is DOUBLE PRECISION array, dimension (J)
!>          The j-vector x.
!>
[in]SEST
!>          SEST is DOUBLE PRECISION
!>          Estimated singular value of j by j matrix L
!>
[in]W
!>          W is DOUBLE PRECISION array, dimension (J)
!>          The j-vector w.
!>
[in]GAMMA
!>          GAMMA is DOUBLE PRECISION
!>          The diagonal element gamma.
!>
[out]SESTPR
!>          SESTPR is DOUBLE PRECISION
!>          Estimated singular value of (j+1) by (j+1) matrix Lhat.
!>
[out]S
!>          S is DOUBLE PRECISION
!>          Sine needed in forming xhat.
!>
[out]C
!>          C is DOUBLE PRECISION
!>          Cosine needed in forming xhat.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file dlaic1.f.

134*
135* -- LAPACK auxiliary routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER J, JOB
141 DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION W( J ), X( J )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 DOUBLE PRECISION ZERO, ONE, TWO
151 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
152 DOUBLE PRECISION HALF, FOUR
153 parameter( half = 0.5d0, four = 4.0d0 )
154* ..
155* .. Local Scalars ..
156 DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
157 $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC abs, max, sign, sqrt
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DDOT, DLAMCH
164 EXTERNAL ddot, dlamch
165* ..
166* .. Executable Statements ..
167*
168 eps = dlamch( 'Epsilon' )
169 alpha = ddot( j, x, 1, w, 1 )
170*
171 absalp = abs( alpha )
172 absgam = abs( gamma )
173 absest = abs( sest )
174*
175 IF( job.EQ.1 ) THEN
176*
177* Estimating largest singular value
178*
179* special cases
180*
181 IF( sest.EQ.zero ) THEN
182 s1 = max( absgam, absalp )
183 IF( s1.EQ.zero ) THEN
184 s = zero
185 c = one
186 sestpr = zero
187 ELSE
188 s = alpha / s1
189 c = gamma / s1
190 tmp = sqrt( s*s+c*c )
191 s = s / tmp
192 c = c / tmp
193 sestpr = s1*tmp
194 END IF
195 RETURN
196 ELSE IF( absgam.LE.eps*absest ) THEN
197 s = one
198 c = zero
199 tmp = max( absest, absalp )
200 s1 = absest / tmp
201 s2 = absalp / tmp
202 sestpr = tmp*sqrt( s1*s1+s2*s2 )
203 RETURN
204 ELSE IF( absalp.LE.eps*absest ) THEN
205 s1 = absgam
206 s2 = absest
207 IF( s1.LE.s2 ) THEN
208 s = one
209 c = zero
210 sestpr = s2
211 ELSE
212 s = zero
213 c = one
214 sestpr = s1
215 END IF
216 RETURN
217 ELSE IF( absest.LE.eps*absalp .OR. absest.LE.eps*absgam ) THEN
218 s1 = absgam
219 s2 = absalp
220 IF( s1.LE.s2 ) THEN
221 tmp = s1 / s2
222 s = sqrt( one+tmp*tmp )
223 sestpr = s2*s
224 c = ( gamma / s2 ) / s
225 s = sign( one, alpha ) / s
226 ELSE
227 tmp = s2 / s1
228 c = sqrt( one+tmp*tmp )
229 sestpr = s1*c
230 s = ( alpha / s1 ) / c
231 c = sign( one, gamma ) / c
232 END IF
233 RETURN
234 ELSE
235*
236* normal case
237*
238 zeta1 = alpha / absest
239 zeta2 = gamma / absest
240*
241 b = ( one-zeta1*zeta1-zeta2*zeta2 )*half
242 c = zeta1*zeta1
243 IF( b.GT.zero ) THEN
244 t = c / ( b+sqrt( b*b+c ) )
245 ELSE
246 t = sqrt( b*b+c ) - b
247 END IF
248*
249 sine = -zeta1 / t
250 cosine = -zeta2 / ( one+t )
251 tmp = sqrt( sine*sine+cosine*cosine )
252 s = sine / tmp
253 c = cosine / tmp
254 sestpr = sqrt( t+one )*absest
255 RETURN
256 END IF
257*
258 ELSE IF( job.EQ.2 ) THEN
259*
260* Estimating smallest singular value
261*
262* special cases
263*
264 IF( sest.EQ.zero ) THEN
265 sestpr = zero
266 IF( max( absgam, absalp ).EQ.zero ) THEN
267 sine = one
268 cosine = zero
269 ELSE
270 sine = -gamma
271 cosine = alpha
272 END IF
273 s1 = max( abs( sine ), abs( cosine ) )
274 s = sine / s1
275 c = cosine / s1
276 tmp = sqrt( s*s+c*c )
277 s = s / tmp
278 c = c / tmp
279 RETURN
280 ELSE IF( absgam.LE.eps*absest ) THEN
281 s = zero
282 c = one
283 sestpr = absgam
284 RETURN
285 ELSE IF( absalp.LE.eps*absest ) THEN
286 s1 = absgam
287 s2 = absest
288 IF( s1.LE.s2 ) THEN
289 s = zero
290 c = one
291 sestpr = s1
292 ELSE
293 s = one
294 c = zero
295 sestpr = s2
296 END IF
297 RETURN
298 ELSE IF( absest.LE.eps*absalp .OR. absest.LE.eps*absgam ) THEN
299 s1 = absgam
300 s2 = absalp
301 IF( s1.LE.s2 ) THEN
302 tmp = s1 / s2
303 c = sqrt( one+tmp*tmp )
304 sestpr = absest*( tmp / c )
305 s = -( gamma / s2 ) / c
306 c = sign( one, alpha ) / c
307 ELSE
308 tmp = s2 / s1
309 s = sqrt( one+tmp*tmp )
310 sestpr = absest / s
311 c = ( alpha / s1 ) / s
312 s = -sign( one, gamma ) / s
313 END IF
314 RETURN
315 ELSE
316*
317* normal case
318*
319 zeta1 = alpha / absest
320 zeta2 = gamma / absest
321*
322 norma = max( one+zeta1*zeta1+abs( zeta1*zeta2 ),
323 $ abs( zeta1*zeta2 )+zeta2*zeta2 )
324*
325* See if root is closer to zero or to ONE
326*
327 test = one + two*( zeta1-zeta2 )*( zeta1+zeta2 )
328 IF( test.GE.zero ) THEN
329*
330* root is close to zero, compute directly
331*
332 b = ( zeta1*zeta1+zeta2*zeta2+one )*half
333 c = zeta2*zeta2
334 t = c / ( b+sqrt( abs( b*b-c ) ) )
335 sine = zeta1 / ( one-t )
336 cosine = -zeta2 / t
337 sestpr = sqrt( t+four*eps*eps*norma )*absest
338 ELSE
339*
340* root is closer to ONE, shift by that amount
341*
342 b = ( zeta2*zeta2+zeta1*zeta1-one )*half
343 c = zeta1*zeta1
344 IF( b.GE.zero ) THEN
345 t = -c / ( b+sqrt( b*b+c ) )
346 ELSE
347 t = b - sqrt( b*b+c )
348 END IF
349 sine = -zeta1 / t
350 cosine = -zeta2 / ( one+t )
351 sestpr = sqrt( one+t+four*eps*eps*norma )*absest
352 END IF
353 tmp = sqrt( sine*sine+cosine*cosine )
354 s = sine / tmp
355 c = cosine / tmp
356 RETURN
357*
358 END IF
359 END IF
360 RETURN
361*
362* End of DLAIC1
363*
ddot
double precision function ddot(n, dx, incx, dy, incy)
DDOT
Definition ddot.f:82

◆ dlaln2()

subroutine dlaln2 ( logical ltrans,
integer na,
integer nw,
double precision smin,
double precision ca,
double precision, dimension( lda, * ) a,
integer lda,
double precision d1,
double precision d2,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision wr,
double precision wi,
double precision, dimension( ldx, * ) x,
integer ldx,
double precision scale,
double precision xnorm,
integer info )

DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.

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

Purpose:
!>
!> DLALN2 solves a system of the form  (ca A - w D ) X = s B
!> or (ca A**T - w D) X = s B   with possible scaling () and
!> perturbation of A.  (A**T means A-transpose.)
!>
!> A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
!> real diagonal matrix, w is a real or complex value, and X and B are
!> NA x 1 matrices -- real if w is real, complex if w is complex.  NA
!> may be 1 or 2.
!>
!> If w is complex, X and B are represented as NA x 2 matrices,
!> the first column of each being the real part and the second
!> being the imaginary part.
!>
!>  is a scaling factor (<= 1), computed by DLALN2, which is
!> so chosen that X can be computed without overflow.  X is further
!> scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
!> than overflow.
!>
!> If both singular values of (ca A - w D) are less than SMIN,
!> SMIN*identity will be used instead of (ca A - w D).  If only one
!> singular value is less than SMIN, one element of (ca A - w D) will be
!> perturbed enough to make the smallest singular value roughly SMIN.
!> If both singular values are at least SMIN, (ca A - w D) will not be
!> perturbed.  In any case, the perturbation will be at most some small
!> multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values
!> are computed by infinity-norm approximations, and thus will only be
!> correct to a factor of 2 or so.
!>
!> Note: all input quantities are assumed to be smaller than overflow
!> by a reasonable factor.  (See BIGNUM.)
!>
Parameters
[in]LTRANS
!>          LTRANS is LOGICAL
!>          =.TRUE.:  A-transpose will be used.
!>          =.FALSE.: A will be used (not transposed.)
!>
[in]NA
!>          NA is INTEGER
!>          The size of the matrix A.  It may (only) be 1 or 2.
!>
[in]NW
!>          NW is INTEGER
!>          1 if  is real, 2 if  is complex.  It may only be 1
!>          or 2.
!>
[in]SMIN
!>          SMIN is DOUBLE PRECISION
!>          The desired lower bound on the singular values of A.  This
!>          should be a safe distance away from underflow or overflow,
!>          say, between (underflow/machine precision) and  (machine
!>          precision * overflow ).  (See BIGNUM and ULP.)
!>
[in]CA
!>          CA is DOUBLE PRECISION
!>          The coefficient c, which A is multiplied by.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,NA)
!>          The NA x NA matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.  It must be at least NA.
!>
[in]D1
!>          D1 is DOUBLE PRECISION
!>          The 1,1 element in the diagonal matrix D.
!>
[in]D2
!>          D2 is DOUBLE PRECISION
!>          The 2,2 element in the diagonal matrix D.  Not used if NA=1.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,NW)
!>          The NA x NW matrix B (right-hand side).  If NW=2 ( is
!>          complex), column 1 contains the real part of B and column 2
!>          contains the imaginary part.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.  It must be at least NA.
!>
[in]WR
!>          WR is DOUBLE PRECISION
!>          The real part of the scalar .
!>
[in]WI
!>          WI is DOUBLE PRECISION
!>          The imaginary part of the scalar .  Not used if NW=1.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (LDX,NW)
!>          The NA x NW matrix X (unknowns), as computed by DLALN2.
!>          If NW=2 ( is complex), on exit, column 1 will contain
!>          the real part of X and column 2 will contain the imaginary
!>          part.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of X.  It must be at least NA.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scale factor that B must be multiplied by to insure
!>          that overflow does not occur when computing X.  Thus,
!>          (ca A - w D) X  will be SCALE*B, not B (ignoring
!>          perturbations of A.)  It will be at most 1.
!>
[out]XNORM
!>          XNORM is DOUBLE PRECISION
!>          The infinity-norm of X, when X is regarded as an NA x NW
!>          real matrix.
!>
[out]INFO
!>          INFO is INTEGER
!>          An error flag.  It will be set to zero if no error occurs,
!>          a negative number if an argument is in error, or a positive
!>          number if  ca A - w D  had to be perturbed.
!>          The possible values are:
!>          = 0: No error occurred, and (ca A - w D) did not have to be
!>                 perturbed.
!>          = 1: (ca A - w D) had to be perturbed to make its smallest
!>               (or only) singular value greater than SMIN.
!>          NOTE: In the interests of speed, this routine does not
!>                check the inputs for errors.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 216 of file dlaln2.f.

218*
219* -- LAPACK auxiliary routine --
220* -- LAPACK is a software package provided by Univ. of Tennessee, --
221* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
222*
223* .. Scalar Arguments ..
224 LOGICAL LTRANS
225 INTEGER INFO, LDA, LDB, LDX, NA, NW
226 DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
227* ..
228* .. Array Arguments ..
229 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
230* ..
231*
232* =====================================================================
233*
234* .. Parameters ..
235 DOUBLE PRECISION ZERO, ONE
236 parameter( zero = 0.0d0, one = 1.0d0 )
237 DOUBLE PRECISION TWO
238 parameter( two = 2.0d0 )
239* ..
240* .. Local Scalars ..
241 INTEGER ICMAX, J
242 DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
243 $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
244 $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
245 $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
246 $ UR22, XI1, XI2, XR1, XR2
247* ..
248* .. Local Arrays ..
249 LOGICAL RSWAP( 4 ), ZSWAP( 4 )
250 INTEGER IPIVOT( 4, 4 )
251 DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
252* ..
253* .. External Functions ..
254 DOUBLE PRECISION DLAMCH
255 EXTERNAL dlamch
256* ..
257* .. External Subroutines ..
258 EXTERNAL dladiv
259* ..
260* .. Intrinsic Functions ..
261 INTRINSIC abs, max
262* ..
263* .. Equivalences ..
264 equivalence( ci( 1, 1 ), civ( 1 ) ),
265 $ ( cr( 1, 1 ), crv( 1 ) )
266* ..
267* .. Data statements ..
268 DATA zswap / .false., .false., .true., .true. /
269 DATA rswap / .false., .true., .false., .true. /
270 DATA ipivot / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
271 $ 3, 2, 1 /
272* ..
273* .. Executable Statements ..
274*
275* Compute BIGNUM
276*
277 smlnum = two*dlamch( 'Safe minimum' )
278 bignum = one / smlnum
279 smini = max( smin, smlnum )
280*
281* Don't check for input errors
282*
283 info = 0
284*
285* Standard Initializations
286*
287 scale = one
288*
289 IF( na.EQ.1 ) THEN
290*
291* 1 x 1 (i.e., scalar) system C X = B
292*
293 IF( nw.EQ.1 ) THEN
294*
295* Real 1x1 system.
296*
297* C = ca A - w D
298*
299 csr = ca*a( 1, 1 ) - wr*d1
300 cnorm = abs( csr )
301*
302* If | C | < SMINI, use C = SMINI
303*
304 IF( cnorm.LT.smini ) THEN
305 csr = smini
306 cnorm = smini
307 info = 1
308 END IF
309*
310* Check scaling for X = B / C
311*
312 bnorm = abs( b( 1, 1 ) )
313 IF( cnorm.LT.one .AND. bnorm.GT.one ) THEN
314 IF( bnorm.GT.bignum*cnorm )
315 $ scale = one / bnorm
316 END IF
317*
318* Compute X
319*
320 x( 1, 1 ) = ( b( 1, 1 )*scale ) / csr
321 xnorm = abs( x( 1, 1 ) )
322 ELSE
323*
324* Complex 1x1 system (w is complex)
325*
326* C = ca A - w D
327*
328 csr = ca*a( 1, 1 ) - wr*d1
329 csi = -wi*d1
330 cnorm = abs( csr ) + abs( csi )
331*
332* If | C | < SMINI, use C = SMINI
333*
334 IF( cnorm.LT.smini ) THEN
335 csr = smini
336 csi = zero
337 cnorm = smini
338 info = 1
339 END IF
340*
341* Check scaling for X = B / C
342*
343 bnorm = abs( b( 1, 1 ) ) + abs( b( 1, 2 ) )
344 IF( cnorm.LT.one .AND. bnorm.GT.one ) THEN
345 IF( bnorm.GT.bignum*cnorm )
346 $ scale = one / bnorm
347 END IF
348*
349* Compute X
350*
351 CALL dladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,
352 $ x( 1, 1 ), x( 1, 2 ) )
353 xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) )
354 END IF
355*
356 ELSE
357*
358* 2x2 System
359*
360* Compute the real part of C = ca A - w D (or ca A**T - w D )
361*
362 cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1
363 cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2
364 IF( ltrans ) THEN
365 cr( 1, 2 ) = ca*a( 2, 1 )
366 cr( 2, 1 ) = ca*a( 1, 2 )
367 ELSE
368 cr( 2, 1 ) = ca*a( 2, 1 )
369 cr( 1, 2 ) = ca*a( 1, 2 )
370 END IF
371*
372 IF( nw.EQ.1 ) THEN
373*
374* Real 2x2 system (w is real)
375*
376* Find the largest element in C
377*
378 cmax = zero
379 icmax = 0
380*
381 DO 10 j = 1, 4
382 IF( abs( crv( j ) ).GT.cmax ) THEN
383 cmax = abs( crv( j ) )
384 icmax = j
385 END IF
386 10 CONTINUE
387*
388* If norm(C) < SMINI, use SMINI*identity.
389*
390 IF( cmax.LT.smini ) THEN
391 bnorm = max( abs( b( 1, 1 ) ), abs( b( 2, 1 ) ) )
392 IF( smini.LT.one .AND. bnorm.GT.one ) THEN
393 IF( bnorm.GT.bignum*smini )
394 $ scale = one / bnorm
395 END IF
396 temp = scale / smini
397 x( 1, 1 ) = temp*b( 1, 1 )
398 x( 2, 1 ) = temp*b( 2, 1 )
399 xnorm = temp*bnorm
400 info = 1
401 RETURN
402 END IF
403*
404* Gaussian elimination with complete pivoting.
405*
406 ur11 = crv( icmax )
407 cr21 = crv( ipivot( 2, icmax ) )
408 ur12 = crv( ipivot( 3, icmax ) )
409 cr22 = crv( ipivot( 4, icmax ) )
410 ur11r = one / ur11
411 lr21 = ur11r*cr21
412 ur22 = cr22 - ur12*lr21
413*
414* If smaller pivot < SMINI, use SMINI
415*
416 IF( abs( ur22 ).LT.smini ) THEN
417 ur22 = smini
418 info = 1
419 END IF
420 IF( rswap( icmax ) ) THEN
421 br1 = b( 2, 1 )
422 br2 = b( 1, 1 )
423 ELSE
424 br1 = b( 1, 1 )
425 br2 = b( 2, 1 )
426 END IF
427 br2 = br2 - lr21*br1
428 bbnd = max( abs( br1*( ur22*ur11r ) ), abs( br2 ) )
429 IF( bbnd.GT.one .AND. abs( ur22 ).LT.one ) THEN
430 IF( bbnd.GE.bignum*abs( ur22 ) )
431 $ scale = one / bbnd
432 END IF
433*
434 xr2 = ( br2*scale ) / ur22
435 xr1 = ( scale*br1 )*ur11r - xr2*( ur11r*ur12 )
436 IF( zswap( icmax ) ) THEN
437 x( 1, 1 ) = xr2
438 x( 2, 1 ) = xr1
439 ELSE
440 x( 1, 1 ) = xr1
441 x( 2, 1 ) = xr2
442 END IF
443 xnorm = max( abs( xr1 ), abs( xr2 ) )
444*
445* Further scaling if norm(A) norm(X) > overflow
446*
447 IF( xnorm.GT.one .AND. cmax.GT.one ) THEN
448 IF( xnorm.GT.bignum / cmax ) THEN
449 temp = cmax / bignum
450 x( 1, 1 ) = temp*x( 1, 1 )
451 x( 2, 1 ) = temp*x( 2, 1 )
452 xnorm = temp*xnorm
453 scale = temp*scale
454 END IF
455 END IF
456 ELSE
457*
458* Complex 2x2 system (w is complex)
459*
460* Find the largest element in C
461*
462 ci( 1, 1 ) = -wi*d1
463 ci( 2, 1 ) = zero
464 ci( 1, 2 ) = zero
465 ci( 2, 2 ) = -wi*d2
466 cmax = zero
467 icmax = 0
468*
469 DO 20 j = 1, 4
470 IF( abs( crv( j ) )+abs( civ( j ) ).GT.cmax ) THEN
471 cmax = abs( crv( j ) ) + abs( civ( j ) )
472 icmax = j
473 END IF
474 20 CONTINUE
475*
476* If norm(C) < SMINI, use SMINI*identity.
477*
478 IF( cmax.LT.smini ) THEN
479 bnorm = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),
480 $ abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) )
481 IF( smini.LT.one .AND. bnorm.GT.one ) THEN
482 IF( bnorm.GT.bignum*smini )
483 $ scale = one / bnorm
484 END IF
485 temp = scale / smini
486 x( 1, 1 ) = temp*b( 1, 1 )
487 x( 2, 1 ) = temp*b( 2, 1 )
488 x( 1, 2 ) = temp*b( 1, 2 )
489 x( 2, 2 ) = temp*b( 2, 2 )
490 xnorm = temp*bnorm
491 info = 1
492 RETURN
493 END IF
494*
495* Gaussian elimination with complete pivoting.
496*
497 ur11 = crv( icmax )
498 ui11 = civ( icmax )
499 cr21 = crv( ipivot( 2, icmax ) )
500 ci21 = civ( ipivot( 2, icmax ) )
501 ur12 = crv( ipivot( 3, icmax ) )
502 ui12 = civ( ipivot( 3, icmax ) )
503 cr22 = crv( ipivot( 4, icmax ) )
504 ci22 = civ( ipivot( 4, icmax ) )
505 IF( icmax.EQ.1 .OR. icmax.EQ.4 ) THEN
506*
507* Code when off-diagonals of pivoted C are real
508*
509 IF( abs( ur11 ).GT.abs( ui11 ) ) THEN
510 temp = ui11 / ur11
511 ur11r = one / ( ur11*( one+temp**2 ) )
512 ui11r = -temp*ur11r
513 ELSE
514 temp = ur11 / ui11
515 ui11r = -one / ( ui11*( one+temp**2 ) )
516 ur11r = -temp*ui11r
517 END IF
518 lr21 = cr21*ur11r
519 li21 = cr21*ui11r
520 ur12s = ur12*ur11r
521 ui12s = ur12*ui11r
522 ur22 = cr22 - ur12*lr21
523 ui22 = ci22 - ur12*li21
524 ELSE
525*
526* Code when diagonals of pivoted C are real
527*
528 ur11r = one / ur11
529 ui11r = zero
530 lr21 = cr21*ur11r
531 li21 = ci21*ur11r
532 ur12s = ur12*ur11r
533 ui12s = ui12*ur11r
534 ur22 = cr22 - ur12*lr21 + ui12*li21
535 ui22 = -ur12*li21 - ui12*lr21
536 END IF
537 u22abs = abs( ur22 ) + abs( ui22 )
538*
539* If smaller pivot < SMINI, use SMINI
540*
541 IF( u22abs.LT.smini ) THEN
542 ur22 = smini
543 ui22 = zero
544 info = 1
545 END IF
546 IF( rswap( icmax ) ) THEN
547 br2 = b( 1, 1 )
548 br1 = b( 2, 1 )
549 bi2 = b( 1, 2 )
550 bi1 = b( 2, 2 )
551 ELSE
552 br1 = b( 1, 1 )
553 br2 = b( 2, 1 )
554 bi1 = b( 1, 2 )
555 bi2 = b( 2, 2 )
556 END IF
557 br2 = br2 - lr21*br1 + li21*bi1
558 bi2 = bi2 - li21*br1 - lr21*bi1
559 bbnd = max( ( abs( br1 )+abs( bi1 ) )*
560 $ ( u22abs*( abs( ur11r )+abs( ui11r ) ) ),
561 $ abs( br2 )+abs( bi2 ) )
562 IF( bbnd.GT.one .AND. u22abs.LT.one ) THEN
563 IF( bbnd.GE.bignum*u22abs ) THEN
564 scale = one / bbnd
565 br1 = scale*br1
566 bi1 = scale*bi1
567 br2 = scale*br2
568 bi2 = scale*bi2
569 END IF
570 END IF
571*
572 CALL dladiv( br2, bi2, ur22, ui22, xr2, xi2 )
573 xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2
574 xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2
575 IF( zswap( icmax ) ) THEN
576 x( 1, 1 ) = xr2
577 x( 2, 1 ) = xr1
578 x( 1, 2 ) = xi2
579 x( 2, 2 ) = xi1
580 ELSE
581 x( 1, 1 ) = xr1
582 x( 2, 1 ) = xr2
583 x( 1, 2 ) = xi1
584 x( 2, 2 ) = xi2
585 END IF
586 xnorm = max( abs( xr1 )+abs( xi1 ), abs( xr2 )+abs( xi2 ) )
587*
588* Further scaling if norm(A) norm(X) > overflow
589*
590 IF( xnorm.GT.one .AND. cmax.GT.one ) THEN
591 IF( xnorm.GT.bignum / cmax ) THEN
592 temp = cmax / bignum
593 x( 1, 1 ) = temp*x( 1, 1 )
594 x( 2, 1 ) = temp*x( 2, 1 )
595 x( 1, 2 ) = temp*x( 1, 2 )
596 x( 2, 2 ) = temp*x( 2, 2 )
597 xnorm = temp*xnorm
598 scale = temp*scale
599 END IF
600 END IF
601 END IF
602 END IF
603*
604 RETURN
605*
606* End of DLALN2
607*
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81

◆ dlangt()

double precision function dlangt ( character norm,
integer n,
double precision, dimension( * ) dl,
double precision, dimension( * ) d,
double precision, dimension( * ) du )

DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix.

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

Purpose:
!>
!> DLANGT  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> real tridiagonal matrix A.
!>
Returns
DLANGT 
!>
!>    DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANGT as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANGT is
!>          set to zero.
!>
[in]DL
!>          DL is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file dlangt.f.

106*
107* -- LAPACK auxiliary routine --
108* -- LAPACK is a software package provided by Univ. of Tennessee, --
109* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
110*
111* .. Scalar Arguments ..
112 CHARACTER NORM
113 INTEGER N
114* ..
115* .. Array Arguments ..
116 DOUBLE PRECISION D( * ), DL( * ), DU( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 DOUBLE PRECISION ONE, ZERO
123 parameter( one = 1.0d+0, zero = 0.0d+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER I
127 DOUBLE PRECISION ANORM, SCALE, SUM, TEMP
128* ..
129* .. External Functions ..
130 LOGICAL LSAME, DISNAN
131 EXTERNAL lsame, disnan
132* ..
133* .. External Subroutines ..
134 EXTERNAL dlassq
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC abs, sqrt
138* ..
139* .. Executable Statements ..
140*
141 IF( n.LE.0 ) THEN
142 anorm = zero
143 ELSE IF( lsame( norm, 'M' ) ) THEN
144*
145* Find max(abs(A(i,j))).
146*
147 anorm = abs( d( n ) )
148 DO 10 i = 1, n - 1
149 IF( anorm.LT.abs( dl( i ) ) .OR. disnan( abs( dl( i ) ) ) )
150 $ anorm = abs(dl(i))
151 IF( anorm.LT.abs( d( i ) ) .OR. disnan( abs( d( i ) ) ) )
152 $ anorm = abs(d(i))
153 IF( anorm.LT.abs( du( i ) ) .OR. disnan(abs( du( i ) ) ) )
154 $ anorm = abs(du(i))
155 10 CONTINUE
156 ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' ) THEN
157*
158* Find norm1(A).
159*
160 IF( n.EQ.1 ) THEN
161 anorm = abs( d( 1 ) )
162 ELSE
163 anorm = abs( d( 1 ) )+abs( dl( 1 ) )
164 temp = abs( d( n ) )+abs( du( n-1 ) )
165 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
166 DO 20 i = 2, n - 1
167 temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
168 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
169 20 CONTINUE
170 END IF
171 ELSE IF( lsame( norm, 'I' ) ) THEN
172*
173* Find normI(A).
174*
175 IF( n.EQ.1 ) THEN
176 anorm = abs( d( 1 ) )
177 ELSE
178 anorm = abs( d( 1 ) )+abs( du( 1 ) )
179 temp = abs( d( n ) )+abs( dl( n-1 ) )
180 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
181 DO 30 i = 2, n - 1
182 temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
183 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
184 30 CONTINUE
185 END IF
186 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
187*
188* Find normF(A).
189*
190 scale = zero
191 sum = one
192 CALL dlassq( n, d, 1, scale, sum )
193 IF( n.GT.1 ) THEN
194 CALL dlassq( n-1, dl, 1, scale, sum )
195 CALL dlassq( n-1, du, 1, scale, sum )
196 END IF
197 anorm = scale*sqrt( sum )
198 END IF
199*
200 dlangt = anorm
201 RETURN
202*
203* End of DLANGT
204*
dlassq
subroutine dlassq(n, x, incx, scl, sumsq)
DLASSQ updates a sum of squares represented in scaled form.
Definition dlassq.f90:137
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
dlangt
double precision function dlangt(norm, n, dl, d, du)
DLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlangt.f:106

◆ dlanhs()

double precision function dlanhs ( character norm,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) work )

DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.

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

Purpose:
!>
!> DLANHS  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> Hessenberg matrix A.
!>
Returns
DLANHS 
!>
!>    DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANHS as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANHS is
!>          set to zero.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The n by n upper Hessenberg matrix A; the part of A below the
!>          first sub-diagonal is not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(N,1).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dlanhs.f.

108*
109* -- LAPACK auxiliary 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 CHARACTER NORM
115 INTEGER LDA, N
116* ..
117* .. Array Arguments ..
118 DOUBLE PRECISION A( LDA, * ), WORK( * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 DOUBLE PRECISION ONE, ZERO
125 parameter( one = 1.0d+0, zero = 0.0d+0 )
126* ..
127* .. Local Scalars ..
128 INTEGER I, J
129 DOUBLE PRECISION SCALE, SUM, VALUE
130* ..
131* .. External Subroutines ..
132 EXTERNAL dlassq
133* ..
134* .. External Functions ..
135 LOGICAL LSAME, DISNAN
136 EXTERNAL lsame, disnan
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC abs, min, sqrt
140* ..
141* .. Executable Statements ..
142*
143 IF( n.EQ.0 ) THEN
144 VALUE = zero
145 ELSE IF( lsame( norm, 'M' ) ) THEN
146*
147* Find max(abs(A(i,j))).
148*
149 VALUE = zero
150 DO 20 j = 1, n
151 DO 10 i = 1, min( n, j+1 )
152 sum = abs( a( i, j ) )
153 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
154 10 CONTINUE
155 20 CONTINUE
156 ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
157*
158* Find norm1(A).
159*
160 VALUE = zero
161 DO 40 j = 1, n
162 sum = zero
163 DO 30 i = 1, min( n, j+1 )
164 sum = sum + abs( a( i, j ) )
165 30 CONTINUE
166 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
167 40 CONTINUE
168 ELSE IF( lsame( norm, 'I' ) ) THEN
169*
170* Find normI(A).
171*
172 DO 50 i = 1, n
173 work( i ) = zero
174 50 CONTINUE
175 DO 70 j = 1, n
176 DO 60 i = 1, min( n, j+1 )
177 work( i ) = work( i ) + abs( a( i, j ) )
178 60 CONTINUE
179 70 CONTINUE
180 VALUE = zero
181 DO 80 i = 1, n
182 sum = work( i )
183 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
184 80 CONTINUE
185 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
186*
187* Find normF(A).
188*
189 scale = zero
190 sum = one
191 DO 90 j = 1, n
192 CALL dlassq( min( n, j+1 ), a( 1, j ), 1, scale, sum )
193 90 CONTINUE
194 VALUE = scale*sqrt( sum )
195 END IF
196*
197 dlanhs = VALUE
198 RETURN
199*
200* End of DLANHS
201*
dlanhs
double precision function dlanhs(norm, n, a, lda, work)
DLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlanhs.f:108

◆ dlansb()

double precision function dlansb ( character norm,
character uplo,
integer n,
integer k,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) work )

DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.

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

Purpose:
!>
!> DLANSB  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the element of  largest absolute value  of an
!> n by n symmetric band matrix A,  with k super-diagonals.
!>
Returns
DLANSB 
!>
!>    DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANSB as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          band matrix A is supplied.
!>          = 'U':  Upper triangular part is supplied
!>          = 'L':  Lower triangular part is supplied
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANSB is
!>          set to zero.
!>
[in]K
!>          K is INTEGER
!>          The number of super-diagonals or sub-diagonals of the
!>          band matrix A.  K >= 0.
!>
[in]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangle of the symmetric band matrix A,
!>          stored in the first K+1 rows of AB.  The j-th column of A is
!>          stored in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= K+1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 127 of file dlansb.f.

129*
130* -- LAPACK auxiliary routine --
131* -- LAPACK is a software package provided by Univ. of Tennessee, --
132* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
133*
134* .. Scalar Arguments ..
135 CHARACTER NORM, UPLO
136 INTEGER K, LDAB, N
137* ..
138* .. Array Arguments ..
139 DOUBLE PRECISION AB( LDAB, * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ONE, ZERO
146 parameter( one = 1.0d+0, zero = 0.0d+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER I, J, L
150 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
151* ..
152* .. External Subroutines ..
153 EXTERNAL dlassq
154* ..
155* .. External Functions ..
156 LOGICAL LSAME, DISNAN
157 EXTERNAL lsame, disnan
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC abs, max, min, sqrt
161* ..
162* .. Executable Statements ..
163*
164 IF( n.EQ.0 ) THEN
165 VALUE = zero
166 ELSE IF( lsame( norm, 'M' ) ) THEN
167*
168* Find max(abs(A(i,j))).
169*
170 VALUE = zero
171 IF( lsame( uplo, 'U' ) ) THEN
172 DO 20 j = 1, n
173 DO 10 i = max( k+2-j, 1 ), k + 1
174 sum = abs( ab( i, j ) )
175 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
176 10 CONTINUE
177 20 CONTINUE
178 ELSE
179 DO 40 j = 1, n
180 DO 30 i = 1, min( n+1-j, k+1 )
181 sum = abs( ab( i, j ) )
182 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
183 30 CONTINUE
184 40 CONTINUE
185 END IF
186 ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
187 $ ( norm.EQ.'1' ) ) THEN
188*
189* Find normI(A) ( = norm1(A), since A is symmetric).
190*
191 VALUE = zero
192 IF( lsame( uplo, 'U' ) ) THEN
193 DO 60 j = 1, n
194 sum = zero
195 l = k + 1 - j
196 DO 50 i = max( 1, j-k ), j - 1
197 absa = abs( ab( l+i, j ) )
198 sum = sum + absa
199 work( i ) = work( i ) + absa
200 50 CONTINUE
201 work( j ) = sum + abs( ab( k+1, j ) )
202 60 CONTINUE
203 DO 70 i = 1, n
204 sum = work( i )
205 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
206 70 CONTINUE
207 ELSE
208 DO 80 i = 1, n
209 work( i ) = zero
210 80 CONTINUE
211 DO 100 j = 1, n
212 sum = work( j ) + abs( ab( 1, j ) )
213 l = 1 - j
214 DO 90 i = j + 1, min( n, j+k )
215 absa = abs( ab( l+i, j ) )
216 sum = sum + absa
217 work( i ) = work( i ) + absa
218 90 CONTINUE
219 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
220 100 CONTINUE
221 END IF
222 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
223*
224* Find normF(A).
225*
226 scale = zero
227 sum = one
228 IF( k.GT.0 ) THEN
229 IF( lsame( uplo, 'U' ) ) THEN
230 DO 110 j = 2, n
231 CALL dlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),
232 $ 1, scale, sum )
233 110 CONTINUE
234 l = k + 1
235 ELSE
236 DO 120 j = 1, n - 1
237 CALL dlassq( min( n-j, k ), ab( 2, j ), 1, scale,
238 $ sum )
239 120 CONTINUE
240 l = 1
241 END IF
242 sum = 2*sum
243 ELSE
244 l = 1
245 END IF
246 CALL dlassq( n, ab( l, 1 ), ldab, scale, sum )
247 VALUE = scale*sqrt( sum )
248 END IF
249*
250 dlansb = VALUE
251 RETURN
252*
253* End of DLANSB
254*
dlansb
double precision function dlansb(norm, uplo, n, k, ab, ldab, work)
DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansb.f:129

◆ dlansp()

double precision function dlansp ( character norm,
character uplo,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) work )

DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.

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

Purpose:
!>
!> DLANSP  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> real symmetric matrix A,  supplied in packed form.
!>
Returns
DLANSP 
!>
!>    DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANSP as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is supplied.
!>          = 'U':  Upper triangular part of A is supplied
!>          = 'L':  Lower triangular part of A is supplied
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is
!>          set to zero.
!>
[in]AP
!>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the symmetric matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file dlansp.f.

114*
115* -- LAPACK auxiliary routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 CHARACTER NORM, UPLO
121 INTEGER N
122* ..
123* .. Array Arguments ..
124 DOUBLE PRECISION AP( * ), WORK( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 DOUBLE PRECISION ONE, ZERO
131 parameter( one = 1.0d+0, zero = 0.0d+0 )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, K
135 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
136* ..
137* .. External Subroutines ..
138 EXTERNAL dlassq
139* ..
140* .. External Functions ..
141 LOGICAL LSAME, DISNAN
142 EXTERNAL lsame, disnan
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC abs, sqrt
146* ..
147* .. Executable Statements ..
148*
149 IF( n.EQ.0 ) THEN
150 VALUE = zero
151 ELSE IF( lsame( norm, 'M' ) ) THEN
152*
153* Find max(abs(A(i,j))).
154*
155 VALUE = zero
156 IF( lsame( uplo, 'U' ) ) THEN
157 k = 1
158 DO 20 j = 1, n
159 DO 10 i = k, k + j - 1
160 sum = abs( ap( i ) )
161 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
162 10 CONTINUE
163 k = k + j
164 20 CONTINUE
165 ELSE
166 k = 1
167 DO 40 j = 1, n
168 DO 30 i = k, k + n - j
169 sum = abs( ap( i ) )
170 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
171 30 CONTINUE
172 k = k + n - j + 1
173 40 CONTINUE
174 END IF
175 ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
176 $ ( norm.EQ.'1' ) ) THEN
177*
178* Find normI(A) ( = norm1(A), since A is symmetric).
179*
180 VALUE = zero
181 k = 1
182 IF( lsame( uplo, 'U' ) ) THEN
183 DO 60 j = 1, n
184 sum = zero
185 DO 50 i = 1, j - 1
186 absa = abs( ap( k ) )
187 sum = sum + absa
188 work( i ) = work( i ) + absa
189 k = k + 1
190 50 CONTINUE
191 work( j ) = sum + abs( ap( k ) )
192 k = k + 1
193 60 CONTINUE
194 DO 70 i = 1, n
195 sum = work( i )
196 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
197 70 CONTINUE
198 ELSE
199 DO 80 i = 1, n
200 work( i ) = zero
201 80 CONTINUE
202 DO 100 j = 1, n
203 sum = work( j ) + abs( ap( k ) )
204 k = k + 1
205 DO 90 i = j + 1, n
206 absa = abs( ap( k ) )
207 sum = sum + absa
208 work( i ) = work( i ) + absa
209 k = k + 1
210 90 CONTINUE
211 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
212 100 CONTINUE
213 END IF
214 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
215*
216* Find normF(A).
217*
218 scale = zero
219 sum = one
220 k = 2
221 IF( lsame( uplo, 'U' ) ) THEN
222 DO 110 j = 2, n
223 CALL dlassq( j-1, ap( k ), 1, scale, sum )
224 k = k + j
225 110 CONTINUE
226 ELSE
227 DO 120 j = 1, n - 1
228 CALL dlassq( n-j, ap( k ), 1, scale, sum )
229 k = k + n - j + 1
230 120 CONTINUE
231 END IF
232 sum = 2*sum
233 k = 1
234 DO 130 i = 1, n
235 IF( ap( k ).NE.zero ) THEN
236 absa = abs( ap( k ) )
237 IF( scale.LT.absa ) THEN
238 sum = one + sum*( scale / absa )**2
239 scale = absa
240 ELSE
241 sum = sum + ( absa / scale )**2
242 END IF
243 END IF
244 IF( lsame( uplo, 'U' ) ) THEN
245 k = k + i + 1
246 ELSE
247 k = k + n - i + 1
248 END IF
249 130 CONTINUE
250 VALUE = scale*sqrt( sum )
251 END IF
252*
253 dlansp = VALUE
254 RETURN
255*
256* End of DLANSP
257*
dlansp
double precision function dlansp(norm, uplo, n, ap, work)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansp.f:114

◆ dlantb()

double precision function dlantb ( character norm,
character uplo,
character diag,
integer n,
integer k,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) work )

DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.

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

Purpose:
!>
!> DLANTB  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the element of  largest absolute value  of an
!> n by n triangular band matrix A,  with ( k + 1 ) diagonals.
!>
Returns
DLANTB 
!>
!>    DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANTB as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANTB is
!>          set to zero.
!>
[in]K
!>          K is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals of the matrix A if UPLO = 'L'.
!>          K >= 0.
!>
[in]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first k+1 rows of AB.  The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!>          Note that when DIAG = 'U', the elements of the array AB
!>          corresponding to the diagonal elements of the matrix A are
!>          not referenced, but are assumed to be one.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= K+1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file dlantb.f.

140*
141* -- LAPACK auxiliary 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 CHARACTER DIAG, NORM, UPLO
147 INTEGER K, LDAB, N
148* ..
149* .. Array Arguments ..
150 DOUBLE PRECISION AB( LDAB, * ), WORK( * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 DOUBLE PRECISION ONE, ZERO
157 parameter( one = 1.0d+0, zero = 0.0d+0 )
158* ..
159* .. Local Scalars ..
160 LOGICAL UDIAG
161 INTEGER I, J, L
162 DOUBLE PRECISION SCALE, SUM, VALUE
163* ..
164* .. External Subroutines ..
165 EXTERNAL dlassq
166* ..
167* .. External Functions ..
168 LOGICAL LSAME, DISNAN
169 EXTERNAL lsame, disnan
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC abs, max, min, sqrt
173* ..
174* .. Executable Statements ..
175*
176 IF( n.EQ.0 ) THEN
177 VALUE = zero
178 ELSE IF( lsame( norm, 'M' ) ) THEN
179*
180* Find max(abs(A(i,j))).
181*
182 IF( lsame( diag, 'U' ) ) THEN
183 VALUE = one
184 IF( lsame( uplo, 'U' ) ) THEN
185 DO 20 j = 1, n
186 DO 10 i = max( k+2-j, 1 ), k
187 sum = abs( ab( i, j ) )
188 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
189 10 CONTINUE
190 20 CONTINUE
191 ELSE
192 DO 40 j = 1, n
193 DO 30 i = 2, min( n+1-j, k+1 )
194 sum = abs( ab( i, j ) )
195 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
196 30 CONTINUE
197 40 CONTINUE
198 END IF
199 ELSE
200 VALUE = zero
201 IF( lsame( uplo, 'U' ) ) THEN
202 DO 60 j = 1, n
203 DO 50 i = max( k+2-j, 1 ), k + 1
204 sum = abs( ab( i, j ) )
205 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
206 50 CONTINUE
207 60 CONTINUE
208 ELSE
209 DO 80 j = 1, n
210 DO 70 i = 1, min( n+1-j, k+1 )
211 sum = abs( ab( i, j ) )
212 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
213 70 CONTINUE
214 80 CONTINUE
215 END IF
216 END IF
217 ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
218*
219* Find norm1(A).
220*
221 VALUE = zero
222 udiag = lsame( diag, 'U' )
223 IF( lsame( uplo, 'U' ) ) THEN
224 DO 110 j = 1, n
225 IF( udiag ) THEN
226 sum = one
227 DO 90 i = max( k+2-j, 1 ), k
228 sum = sum + abs( ab( i, j ) )
229 90 CONTINUE
230 ELSE
231 sum = zero
232 DO 100 i = max( k+2-j, 1 ), k + 1
233 sum = sum + abs( ab( i, j ) )
234 100 CONTINUE
235 END IF
236 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
237 110 CONTINUE
238 ELSE
239 DO 140 j = 1, n
240 IF( udiag ) THEN
241 sum = one
242 DO 120 i = 2, min( n+1-j, k+1 )
243 sum = sum + abs( ab( i, j ) )
244 120 CONTINUE
245 ELSE
246 sum = zero
247 DO 130 i = 1, min( n+1-j, k+1 )
248 sum = sum + abs( ab( i, j ) )
249 130 CONTINUE
250 END IF
251 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
252 140 CONTINUE
253 END IF
254 ELSE IF( lsame( norm, 'I' ) ) THEN
255*
256* Find normI(A).
257*
258 VALUE = zero
259 IF( lsame( uplo, 'U' ) ) THEN
260 IF( lsame( diag, 'U' ) ) THEN
261 DO 150 i = 1, n
262 work( i ) = one
263 150 CONTINUE
264 DO 170 j = 1, n
265 l = k + 1 - j
266 DO 160 i = max( 1, j-k ), j - 1
267 work( i ) = work( i ) + abs( ab( l+i, j ) )
268 160 CONTINUE
269 170 CONTINUE
270 ELSE
271 DO 180 i = 1, n
272 work( i ) = zero
273 180 CONTINUE
274 DO 200 j = 1, n
275 l = k + 1 - j
276 DO 190 i = max( 1, j-k ), j
277 work( i ) = work( i ) + abs( ab( l+i, j ) )
278 190 CONTINUE
279 200 CONTINUE
280 END IF
281 ELSE
282 IF( lsame( diag, 'U' ) ) THEN
283 DO 210 i = 1, n
284 work( i ) = one
285 210 CONTINUE
286 DO 230 j = 1, n
287 l = 1 - j
288 DO 220 i = j + 1, min( n, j+k )
289 work( i ) = work( i ) + abs( ab( l+i, j ) )
290 220 CONTINUE
291 230 CONTINUE
292 ELSE
293 DO 240 i = 1, n
294 work( i ) = zero
295 240 CONTINUE
296 DO 260 j = 1, n
297 l = 1 - j
298 DO 250 i = j, min( n, j+k )
299 work( i ) = work( i ) + abs( ab( l+i, j ) )
300 250 CONTINUE
301 260 CONTINUE
302 END IF
303 END IF
304 DO 270 i = 1, n
305 sum = work( i )
306 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
307 270 CONTINUE
308 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
309*
310* Find normF(A).
311*
312 IF( lsame( uplo, 'U' ) ) THEN
313 IF( lsame( diag, 'U' ) ) THEN
314 scale = one
315 sum = n
316 IF( k.GT.0 ) THEN
317 DO 280 j = 2, n
318 CALL dlassq( min( j-1, k ),
319 $ ab( max( k+2-j, 1 ), j ), 1, scale,
320 $ sum )
321 280 CONTINUE
322 END IF
323 ELSE
324 scale = zero
325 sum = one
326 DO 290 j = 1, n
327 CALL dlassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),
328 $ 1, scale, sum )
329 290 CONTINUE
330 END IF
331 ELSE
332 IF( lsame( diag, 'U' ) ) THEN
333 scale = one
334 sum = n
335 IF( k.GT.0 ) THEN
336 DO 300 j = 1, n - 1
337 CALL dlassq( min( n-j, k ), ab( 2, j ), 1, scale,
338 $ sum )
339 300 CONTINUE
340 END IF
341 ELSE
342 scale = zero
343 sum = one
344 DO 310 j = 1, n
345 CALL dlassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,
346 $ sum )
347 310 CONTINUE
348 END IF
349 END IF
350 VALUE = scale*sqrt( sum )
351 END IF
352*
353 dlantb = VALUE
354 RETURN
355*
356* End of DLANTB
357*
dlantb
double precision function dlantb(norm, uplo, diag, n, k, ab, ldab, work)
DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantb.f:140

◆ dlantp()

double precision function dlantp ( character norm,
character uplo,
character diag,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) work )

DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.

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

Purpose:
!>
!> DLANTP  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> triangular matrix A, supplied in packed form.
!>
Returns
DLANTP 
!>
!>    DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANTP as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, DLANTP is
!>          set to zero.
!>
[in]AP
!>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>          Note that when DIAG = 'U', the elements of the array AP
!>          corresponding to the diagonal elements of the matrix A are
!>          not referenced, but are assumed to be one.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dlantp.f.

124*
125* -- LAPACK auxiliary routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER DIAG, NORM, UPLO
131 INTEGER N
132* ..
133* .. Array Arguments ..
134 DOUBLE PRECISION AP( * ), WORK( * )
135* ..
136*
137* =====================================================================
138*
139* .. Parameters ..
140 DOUBLE PRECISION ONE, ZERO
141 parameter( one = 1.0d+0, zero = 0.0d+0 )
142* ..
143* .. Local Scalars ..
144 LOGICAL UDIAG
145 INTEGER I, J, K
146 DOUBLE PRECISION SCALE, SUM, VALUE
147* ..
148* .. External Subroutines ..
149 EXTERNAL dlassq
150* ..
151* .. External Functions ..
152 LOGICAL LSAME, DISNAN
153 EXTERNAL lsame, disnan
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC abs, sqrt
157* ..
158* .. Executable Statements ..
159*
160 IF( n.EQ.0 ) THEN
161 VALUE = zero
162 ELSE IF( lsame( norm, 'M' ) ) THEN
163*
164* Find max(abs(A(i,j))).
165*
166 k = 1
167 IF( lsame( diag, 'U' ) ) THEN
168 VALUE = one
169 IF( lsame( uplo, 'U' ) ) THEN
170 DO 20 j = 1, n
171 DO 10 i = k, k + j - 2
172 sum = abs( ap( i ) )
173 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
174 10 CONTINUE
175 k = k + j
176 20 CONTINUE
177 ELSE
178 DO 40 j = 1, n
179 DO 30 i = k + 1, k + n - j
180 sum = abs( ap( i ) )
181 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
182 30 CONTINUE
183 k = k + n - j + 1
184 40 CONTINUE
185 END IF
186 ELSE
187 VALUE = zero
188 IF( lsame( uplo, 'U' ) ) THEN
189 DO 60 j = 1, n
190 DO 50 i = k, k + j - 1
191 sum = abs( ap( i ) )
192 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
193 50 CONTINUE
194 k = k + j
195 60 CONTINUE
196 ELSE
197 DO 80 j = 1, n
198 DO 70 i = k, k + n - j
199 sum = abs( ap( i ) )
200 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
201 70 CONTINUE
202 k = k + n - j + 1
203 80 CONTINUE
204 END IF
205 END IF
206 ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
207*
208* Find norm1(A).
209*
210 VALUE = zero
211 k = 1
212 udiag = lsame( diag, 'U' )
213 IF( lsame( uplo, 'U' ) ) THEN
214 DO 110 j = 1, n
215 IF( udiag ) THEN
216 sum = one
217 DO 90 i = k, k + j - 2
218 sum = sum + abs( ap( i ) )
219 90 CONTINUE
220 ELSE
221 sum = zero
222 DO 100 i = k, k + j - 1
223 sum = sum + abs( ap( i ) )
224 100 CONTINUE
225 END IF
226 k = k + j
227 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
228 110 CONTINUE
229 ELSE
230 DO 140 j = 1, n
231 IF( udiag ) THEN
232 sum = one
233 DO 120 i = k + 1, k + n - j
234 sum = sum + abs( ap( i ) )
235 120 CONTINUE
236 ELSE
237 sum = zero
238 DO 130 i = k, k + n - j
239 sum = sum + abs( ap( i ) )
240 130 CONTINUE
241 END IF
242 k = k + n - j + 1
243 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
244 140 CONTINUE
245 END IF
246 ELSE IF( lsame( norm, 'I' ) ) THEN
247*
248* Find normI(A).
249*
250 k = 1
251 IF( lsame( uplo, 'U' ) ) THEN
252 IF( lsame( diag, 'U' ) ) THEN
253 DO 150 i = 1, n
254 work( i ) = one
255 150 CONTINUE
256 DO 170 j = 1, n
257 DO 160 i = 1, j - 1
258 work( i ) = work( i ) + abs( ap( k ) )
259 k = k + 1
260 160 CONTINUE
261 k = k + 1
262 170 CONTINUE
263 ELSE
264 DO 180 i = 1, n
265 work( i ) = zero
266 180 CONTINUE
267 DO 200 j = 1, n
268 DO 190 i = 1, j
269 work( i ) = work( i ) + abs( ap( k ) )
270 k = k + 1
271 190 CONTINUE
272 200 CONTINUE
273 END IF
274 ELSE
275 IF( lsame( diag, 'U' ) ) THEN
276 DO 210 i = 1, n
277 work( i ) = one
278 210 CONTINUE
279 DO 230 j = 1, n
280 k = k + 1
281 DO 220 i = j + 1, n
282 work( i ) = work( i ) + abs( ap( k ) )
283 k = k + 1
284 220 CONTINUE
285 230 CONTINUE
286 ELSE
287 DO 240 i = 1, n
288 work( i ) = zero
289 240 CONTINUE
290 DO 260 j = 1, n
291 DO 250 i = j, n
292 work( i ) = work( i ) + abs( ap( k ) )
293 k = k + 1
294 250 CONTINUE
295 260 CONTINUE
296 END IF
297 END IF
298 VALUE = zero
299 DO 270 i = 1, n
300 sum = work( i )
301 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
302 270 CONTINUE
303 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
304*
305* Find normF(A).
306*
307 IF( lsame( uplo, 'U' ) ) THEN
308 IF( lsame( diag, 'U' ) ) THEN
309 scale = one
310 sum = n
311 k = 2
312 DO 280 j = 2, n
313 CALL dlassq( j-1, ap( k ), 1, scale, sum )
314 k = k + j
315 280 CONTINUE
316 ELSE
317 scale = zero
318 sum = one
319 k = 1
320 DO 290 j = 1, n
321 CALL dlassq( j, ap( k ), 1, scale, sum )
322 k = k + j
323 290 CONTINUE
324 END IF
325 ELSE
326 IF( lsame( diag, 'U' ) ) THEN
327 scale = one
328 sum = n
329 k = 2
330 DO 300 j = 1, n - 1
331 CALL dlassq( n-j, ap( k ), 1, scale, sum )
332 k = k + n - j + 1
333 300 CONTINUE
334 ELSE
335 scale = zero
336 sum = one
337 k = 1
338 DO 310 j = 1, n
339 CALL dlassq( n-j+1, ap( k ), 1, scale, sum )
340 k = k + n - j + 1
341 310 CONTINUE
342 END IF
343 END IF
344 VALUE = scale*sqrt( sum )
345 END IF
346*
347 dlantp = VALUE
348 RETURN
349*
350* End of DLANTP
351*
dlantp
double precision function dlantp(norm, uplo, diag, n, ap, work)
DLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantp.f:124

◆ dlantr()

double precision function dlantr ( character norm,
character uplo,
character diag,
integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) work )

DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.

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

Purpose:
!>
!> DLANTR  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> trapezoidal or triangular matrix A.
!>
Returns
DLANTR 
!>
!>    DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!>
Parameters
[in]NORM
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in DLANTR as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower trapezoidal.
!>          = 'U':  Upper trapezoidal
!>          = 'L':  Lower trapezoidal
!>          Note that A is triangular instead of trapezoidal if M = N.
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A has unit diagonal.
!>          = 'N':  Non-unit diagonal
!>          = 'U':  Unit diagonal
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0, and if
!>          UPLO = 'U', M <= N.  When M = 0, DLANTR is set to zero.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0, and if
!>          UPLO = 'L', N <= M.  When N = 0, DLANTR is set to zero.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The trapezoidal matrix A (A is triangular if M = N).
!>          If UPLO = 'U', the leading m by n upper trapezoidal part of
!>          the array A contains the upper trapezoidal matrix, and the
!>          strictly lower triangular part of A is not referenced.
!>          If UPLO = 'L', the leading m by n lower trapezoidal part of
!>          the array A contains the lower trapezoidal matrix, and the
!>          strictly upper triangular part of A is not referenced.  Note
!>          that when DIAG = 'U', the diagonal elements of A are not
!>          referenced and are assumed to be one.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(M,1).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file dlantr.f.

141*
142* -- LAPACK auxiliary routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 CHARACTER DIAG, NORM, UPLO
148 INTEGER LDA, M, N
149* ..
150* .. Array Arguments ..
151 DOUBLE PRECISION A( LDA, * ), WORK( * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 DOUBLE PRECISION ONE, ZERO
158 parameter( one = 1.0d+0, zero = 0.0d+0 )
159* ..
160* .. Local Scalars ..
161 LOGICAL UDIAG
162 INTEGER I, J
163 DOUBLE PRECISION SCALE, SUM, VALUE
164* ..
165* .. External Subroutines ..
166 EXTERNAL dlassq
167* ..
168* .. External Functions ..
169 LOGICAL LSAME, DISNAN
170 EXTERNAL lsame, disnan
171* ..
172* .. Intrinsic Functions ..
173 INTRINSIC abs, min, sqrt
174* ..
175* .. Executable Statements ..
176*
177 IF( min( m, n ).EQ.0 ) THEN
178 VALUE = zero
179 ELSE IF( lsame( norm, 'M' ) ) THEN
180*
181* Find max(abs(A(i,j))).
182*
183 IF( lsame( diag, 'U' ) ) THEN
184 VALUE = one
185 IF( lsame( uplo, 'U' ) ) THEN
186 DO 20 j = 1, n
187 DO 10 i = 1, min( m, j-1 )
188 sum = abs( a( i, j ) )
189 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
190 10 CONTINUE
191 20 CONTINUE
192 ELSE
193 DO 40 j = 1, n
194 DO 30 i = j + 1, m
195 sum = abs( a( i, j ) )
196 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
197 30 CONTINUE
198 40 CONTINUE
199 END IF
200 ELSE
201 VALUE = zero
202 IF( lsame( uplo, 'U' ) ) THEN
203 DO 60 j = 1, n
204 DO 50 i = 1, min( m, j )
205 sum = abs( a( i, j ) )
206 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
207 50 CONTINUE
208 60 CONTINUE
209 ELSE
210 DO 80 j = 1, n
211 DO 70 i = j, m
212 sum = abs( a( i, j ) )
213 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
214 70 CONTINUE
215 80 CONTINUE
216 END IF
217 END IF
218 ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
219*
220* Find norm1(A).
221*
222 VALUE = zero
223 udiag = lsame( diag, 'U' )
224 IF( lsame( uplo, 'U' ) ) THEN
225 DO 110 j = 1, n
226 IF( ( udiag ) .AND. ( j.LE.m ) ) THEN
227 sum = one
228 DO 90 i = 1, j - 1
229 sum = sum + abs( a( i, j ) )
230 90 CONTINUE
231 ELSE
232 sum = zero
233 DO 100 i = 1, min( m, j )
234 sum = sum + abs( a( i, j ) )
235 100 CONTINUE
236 END IF
237 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
238 110 CONTINUE
239 ELSE
240 DO 140 j = 1, n
241 IF( udiag ) THEN
242 sum = one
243 DO 120 i = j + 1, m
244 sum = sum + abs( a( i, j ) )
245 120 CONTINUE
246 ELSE
247 sum = zero
248 DO 130 i = j, m
249 sum = sum + abs( a( i, j ) )
250 130 CONTINUE
251 END IF
252 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
253 140 CONTINUE
254 END IF
255 ELSE IF( lsame( norm, 'I' ) ) THEN
256*
257* Find normI(A).
258*
259 IF( lsame( uplo, 'U' ) ) THEN
260 IF( lsame( diag, 'U' ) ) THEN
261 DO 150 i = 1, m
262 work( i ) = one
263 150 CONTINUE
264 DO 170 j = 1, n
265 DO 160 i = 1, min( m, j-1 )
266 work( i ) = work( i ) + abs( a( i, j ) )
267 160 CONTINUE
268 170 CONTINUE
269 ELSE
270 DO 180 i = 1, m
271 work( i ) = zero
272 180 CONTINUE
273 DO 200 j = 1, n
274 DO 190 i = 1, min( m, j )
275 work( i ) = work( i ) + abs( a( i, j ) )
276 190 CONTINUE
277 200 CONTINUE
278 END IF
279 ELSE
280 IF( lsame( diag, 'U' ) ) THEN
281 DO 210 i = 1, min( m, n )
282 work( i ) = one
283 210 CONTINUE
284 DO 220 i = n + 1, m
285 work( i ) = zero
286 220 CONTINUE
287 DO 240 j = 1, n
288 DO 230 i = j + 1, m
289 work( i ) = work( i ) + abs( a( i, j ) )
290 230 CONTINUE
291 240 CONTINUE
292 ELSE
293 DO 250 i = 1, m
294 work( i ) = zero
295 250 CONTINUE
296 DO 270 j = 1, n
297 DO 260 i = j, m
298 work( i ) = work( i ) + abs( a( i, j ) )
299 260 CONTINUE
300 270 CONTINUE
301 END IF
302 END IF
303 VALUE = zero
304 DO 280 i = 1, m
305 sum = work( i )
306 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
307 280 CONTINUE
308 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
309*
310* Find normF(A).
311*
312 IF( lsame( uplo, 'U' ) ) THEN
313 IF( lsame( diag, 'U' ) ) THEN
314 scale = one
315 sum = min( m, n )
316 DO 290 j = 2, n
317 CALL dlassq( min( m, j-1 ), a( 1, j ), 1, scale, sum )
318 290 CONTINUE
319 ELSE
320 scale = zero
321 sum = one
322 DO 300 j = 1, n
323 CALL dlassq( min( m, j ), a( 1, j ), 1, scale, sum )
324 300 CONTINUE
325 END IF
326 ELSE
327 IF( lsame( diag, 'U' ) ) THEN
328 scale = one
329 sum = min( m, n )
330 DO 310 j = 1, n
331 CALL dlassq( m-j, a( min( m, j+1 ), j ), 1, scale,
332 $ sum )
333 310 CONTINUE
334 ELSE
335 scale = zero
336 sum = one
337 DO 320 j = 1, n
338 CALL dlassq( m-j+1, a( j, j ), 1, scale, sum )
339 320 CONTINUE
340 END IF
341 END IF
342 VALUE = scale*sqrt( sum )
343 END IF
344*
345 dlantr = VALUE
346 RETURN
347*
348* End of DLANTR
349*
dlantr
double precision function dlantr(norm, uplo, diag, m, n, a, lda, work)
DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantr.f:141

◆ dlanv2()

subroutine dlanv2 ( double precision a,
double precision b,
double precision c,
double precision d,
double precision rt1r,
double precision rt1i,
double precision rt2r,
double precision rt2i,
double precision cs,
double precision sn )

DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.

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

Purpose:
!>
!> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
!> matrix in standard form:
!>
!>      [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
!>      [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
!>
!> where either
!> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
!> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
!> conjugate eigenvalues.
!>
Parameters
[in,out]A
!>          A is DOUBLE PRECISION
!>
[in,out]B
!>          B is DOUBLE PRECISION
!>
[in,out]C
!>          C is DOUBLE PRECISION
!>
[in,out]D
!>          D is DOUBLE PRECISION
!>          On entry, the elements of the input matrix.
!>          On exit, they are overwritten by the elements of the
!>          standardised Schur form.
!>
[out]RT1R
!>          RT1R is DOUBLE PRECISION
!>
[out]RT1I
!>          RT1I is DOUBLE PRECISION
!>
[out]RT2R
!>          RT2R is DOUBLE PRECISION
!>
[out]RT2I
!>          RT2I is DOUBLE PRECISION
!>          The real and imaginary parts of the eigenvalues. If the
!>          eigenvalues are a complex conjugate pair, RT1I > 0.
!>
[out]CS
!>          CS is DOUBLE PRECISION
!>
[out]SN
!>          SN is DOUBLE PRECISION
!>          Parameters of the rotation matrix.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Modified by V. Sima, Research Institute for Informatics, Bucharest,
!>  Romania, to reduce the risk of cancellation errors,
!>  when computing real eigenvalues, and to ensure, if possible, that
!>  abs(RT1R) >= abs(RT2R).
!>

Definition at line 126 of file dlanv2.f.

127*
128* -- LAPACK auxiliary routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 DOUBLE PRECISION ZERO, HALF, ONE, TWO
140 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
141 $ two = 2.0d0 )
142 DOUBLE PRECISION MULTPL
143 parameter( multpl = 4.0d+0 )
144* ..
145* .. Local Scalars ..
146 DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
147 $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z, SAFMIN,
148 $ SAFMN2, SAFMX2
149 INTEGER COUNT
150* ..
151* .. External Functions ..
152 DOUBLE PRECISION DLAMCH, DLAPY2
153 EXTERNAL dlamch, dlapy2
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC abs, max, min, sign, sqrt
157* ..
158* .. Executable Statements ..
159*
160 safmin = dlamch( 'S' )
161 eps = dlamch( 'P' )
162 safmn2 = dlamch( 'B' )**int( log( safmin / eps ) /
163 $ log( dlamch( 'B' ) ) / two )
164 safmx2 = one / safmn2
165 IF( c.EQ.zero ) THEN
166 cs = one
167 sn = zero
168*
169 ELSE IF( b.EQ.zero ) THEN
170*
171* Swap rows and columns
172*
173 cs = zero
174 sn = one
175 temp = d
176 d = a
177 a = temp
178 b = -c
179 c = zero
180*
181 ELSE IF( ( a-d ).EQ.zero .AND. sign( one, b ).NE.sign( one, c ) )
182 $ THEN
183 cs = one
184 sn = zero
185*
186 ELSE
187*
188 temp = a - d
189 p = half*temp
190 bcmax = max( abs( b ), abs( c ) )
191 bcmis = min( abs( b ), abs( c ) )*sign( one, b )*sign( one, c )
192 scale = max( abs( p ), bcmax )
193 z = ( p / scale )*p + ( bcmax / scale )*bcmis
194*
195* If Z is of the order of the machine accuracy, postpone the
196* decision on the nature of eigenvalues
197*
198 IF( z.GE.multpl*eps ) THEN
199*
200* Real eigenvalues. Compute A and D.
201*
202 z = p + sign( sqrt( scale )*sqrt( z ), p )
203 a = d + z
204 d = d - ( bcmax / z )*bcmis
205*
206* Compute B and the rotation matrix
207*
208 tau = dlapy2( c, z )
209 cs = z / tau
210 sn = c / tau
211 b = b - c
212 c = zero
213*
214 ELSE
215*
216* Complex eigenvalues, or real (almost) equal eigenvalues.
217* Make diagonal elements equal.
218*
219 count = 0
220 sigma = b + c
221 10 CONTINUE
222 count = count + 1
223 scale = max( abs(temp), abs(sigma) )
224 IF( scale.GE.safmx2 ) THEN
225 sigma = sigma * safmn2
226 temp = temp * safmn2
227 IF (count .LE. 20)
228 $ GOTO 10
229 END IF
230 IF( scale.LE.safmn2 ) THEN
231 sigma = sigma * safmx2
232 temp = temp * safmx2
233 IF (count .LE. 20)
234 $ GOTO 10
235 END IF
236 p = half*temp
237 tau = dlapy2( sigma, temp )
238 cs = sqrt( half*( one+abs( sigma ) / tau ) )
239 sn = -( p / ( tau*cs ) )*sign( one, sigma )
240*
241* Compute [ AA BB ] = [ A B ] [ CS -SN ]
242* [ CC DD ] [ C D ] [ SN CS ]
243*
244 aa = a*cs + b*sn
245 bb = -a*sn + b*cs
246 cc = c*cs + d*sn
247 dd = -c*sn + d*cs
248*
249* Compute [ A B ] = [ CS SN ] [ AA BB ]
250* [ C D ] [-SN CS ] [ CC DD ]
251*
252 a = aa*cs + cc*sn
253 b = bb*cs + dd*sn
254 c = -aa*sn + cc*cs
255 d = -bb*sn + dd*cs
256*
257 temp = half*( a+d )
258 a = temp
259 d = temp
260*
261 IF( c.NE.zero ) THEN
262 IF( b.NE.zero ) THEN
263 IF( sign( one, b ).EQ.sign( one, c ) ) THEN
264*
265* Real eigenvalues: reduce to upper triangular form
266*
267 sab = sqrt( abs( b ) )
268 sac = sqrt( abs( c ) )
269 p = sign( sab*sac, c )
270 tau = one / sqrt( abs( b+c ) )
271 a = temp + p
272 d = temp - p
273 b = b - c
274 c = zero
275 cs1 = sab*tau
276 sn1 = sac*tau
277 temp = cs*cs1 - sn*sn1
278 sn = cs*sn1 + sn*cs1
279 cs = temp
280 END IF
281 ELSE
282 b = -c
283 c = zero
284 temp = cs
285 cs = -sn
286 sn = temp
287 END IF
288 END IF
289 END IF
290*
291 END IF
292*
293* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
294*
295 rt1r = a
296 rt2r = d
297 IF( c.EQ.zero ) THEN
298 rt1i = zero
299 rt2i = zero
300 ELSE
301 rt1i = sqrt( abs( b ) )*sqrt( abs( c ) )
302 rt2i = -rt1i
303 END IF
304 RETURN
305*
306* End of DLANV2
307*

◆ dlapll()

subroutine dlapll ( integer n,
double precision, dimension( * ) x,
integer incx,
double precision, dimension( * ) y,
integer incy,
double precision ssmin )

DLAPLL measures the linear dependence of two vectors.

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

Purpose:
!>
!> Given two column vectors X and Y, let
!>
!>                      A = ( X Y ).
!>
!> The subroutine first computes the QR factorization of A = Q*R,
!> and then computes the SVD of the 2-by-2 upper triangular matrix R.
!> The smaller singular value of R is returned in SSMIN, which is used
!> as the measurement of the linear dependency of the vectors X and Y.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The length of the vectors X and Y.
!>
[in,out]X
!>          X is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          On entry, X contains the N-vector X.
!>          On exit, X is overwritten.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between successive elements of X. INCX > 0.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCY)
!>          On entry, Y contains the N-vector Y.
!>          On exit, Y is overwritten.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between successive elements of Y. INCY > 0.
!>
[out]SSMIN
!>          SSMIN is DOUBLE PRECISION
!>          The smallest singular value of the N-by-2 matrix A = ( X Y ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file dlapll.f.

102*
103* -- LAPACK auxiliary routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 INTEGER INCX, INCY, N
109 DOUBLE PRECISION SSMIN
110* ..
111* .. Array Arguments ..
112 DOUBLE PRECISION X( * ), Y( * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ZERO, ONE
119 parameter( zero = 0.0d+0, one = 1.0d+0 )
120* ..
121* .. Local Scalars ..
122 DOUBLE PRECISION A11, A12, A22, C, SSMAX, TAU
123* ..
124* .. External Functions ..
125 DOUBLE PRECISION DDOT
126 EXTERNAL ddot
127* ..
128* .. External Subroutines ..
129 EXTERNAL daxpy, dlarfg, dlas2
130* ..
131* .. Executable Statements ..
132*
133* Quick return if possible
134*
135 IF( n.LE.1 ) THEN
136 ssmin = zero
137 RETURN
138 END IF
139*
140* Compute the QR factorization of the N-by-2 matrix ( X Y )
141*
142 CALL dlarfg( n, x( 1 ), x( 1+incx ), incx, tau )
143 a11 = x( 1 )
144 x( 1 ) = one
145*
146 c = -tau*ddot( n, x, incx, y, incy )
147 CALL daxpy( n, c, x, incx, y, incy )
148*
149 CALL dlarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau )
150*
151 a12 = y( 1 )
152 a22 = y( 1+incy )
153*
154* Compute the SVD of 2-by-2 Upper triangular matrix.
155*
156 CALL dlas2( a11, a12, a22, ssmin, ssmax )
157*
158 RETURN
159*
160* End of DLAPLL
161*
dlas2
subroutine dlas2(f, g, h, ssmin, ssmax)
DLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition dlas2.f:107

◆ dlapmr()

subroutine dlapmr ( logical forwrd,
integer m,
integer n,
double precision, dimension( ldx, * ) x,
integer ldx,
integer, dimension( * ) k )

DLAPMR rearranges rows of a matrix as specified by a permutation vector.

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

Purpose:
!>
!> DLAPMR rearranges the rows of the M by N matrix X as specified
!> by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.
!> If FORWRD = .TRUE.,  forward permutation:
!>
!>      X(K(I),*) is moved X(I,*) for I = 1,2,...,M.
!>
!> If FORWRD = .FALSE., backward permutation:
!>
!>      X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.
!>
Parameters
[in]FORWRD
!>          FORWRD is LOGICAL
!>          = .TRUE., forward permutation
!>          = .FALSE., backward permutation
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix X. N >= 0.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (LDX,N)
!>          On entry, the M by N matrix X.
!>          On exit, X contains the permuted matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X, LDX >= MAX(1,M).
!>
[in,out]K
!>          K is INTEGER array, dimension (M)
!>          On entry, K contains the permutation vector. K is used as
!>          internal workspace, but reset to its original value on
!>          output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dlapmr.f.

104*
105* -- LAPACK auxiliary routine --
106* -- LAPACK is a software package provided by Univ. of Tennessee, --
107* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
108*
109* .. Scalar Arguments ..
110 LOGICAL FORWRD
111 INTEGER LDX, M, N
112* ..
113* .. Array Arguments ..
114 INTEGER K( * )
115 DOUBLE PRECISION X( LDX, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, IN, J, JJ
122 DOUBLE PRECISION TEMP
123* ..
124* .. Executable Statements ..
125*
126 IF( m.LE.1 )
127 $ RETURN
128*
129 DO 10 i = 1, m
130 k( i ) = -k( i )
131 10 CONTINUE
132*
133 IF( forwrd ) THEN
134*
135* Forward permutation
136*
137 DO 50 i = 1, m
138*
139 IF( k( i ).GT.0 )
140 $ GO TO 40
141*
142 j = i
143 k( j ) = -k( j )
144 in = k( j )
145*
146 20 CONTINUE
147 IF( k( in ).GT.0 )
148 $ GO TO 40
149*
150 DO 30 jj = 1, n
151 temp = x( j, jj )
152 x( j, jj ) = x( in, jj )
153 x( in, jj ) = temp
154 30 CONTINUE
155*
156 k( in ) = -k( in )
157 j = in
158 in = k( in )
159 GO TO 20
160*
161 40 CONTINUE
162*
163 50 CONTINUE
164*
165 ELSE
166*
167* Backward permutation
168*
169 DO 90 i = 1, m
170*
171 IF( k( i ).GT.0 )
172 $ GO TO 80
173*
174 k( i ) = -k( i )
175 j = k( i )
176 60 CONTINUE
177 IF( j.EQ.i )
178 $ GO TO 80
179*
180 DO 70 jj = 1, n
181 temp = x( i, jj )
182 x( i, jj ) = x( j, jj )
183 x( j, jj ) = temp
184 70 CONTINUE
185*
186 k( j ) = -k( j )
187 j = k( j )
188 GO TO 60
189*
190 80 CONTINUE
191*
192 90 CONTINUE
193*
194 END IF
195*
196 RETURN
197*
198* End of DLAPMR
199*

◆ dlapmt()

subroutine dlapmt ( logical forwrd,
integer m,
integer n,
double precision, dimension( ldx, * ) x,
integer ldx,
integer, dimension( * ) k )

DLAPMT performs a forward or backward permutation of the columns of a matrix.

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

Purpose:
!>
!> DLAPMT rearranges the columns of the M by N matrix X as specified
!> by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
!> If FORWRD = .TRUE.,  forward permutation:
!>
!>      X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
!>
!> If FORWRD = .FALSE., backward permutation:
!>
!>      X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
!>
Parameters
[in]FORWRD
!>          FORWRD is LOGICAL
!>          = .TRUE., forward permutation
!>          = .FALSE., backward permutation
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix X. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix X. N >= 0.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (LDX,N)
!>          On entry, the M by N matrix X.
!>          On exit, X contains the permuted matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X, LDX >= MAX(1,M).
!>
[in,out]K
!>          K is INTEGER array, dimension (N)
!>          On entry, K contains the permutation vector. K is used as
!>          internal workspace, but reset to its original value on
!>          output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dlapmt.f.

104*
105* -- LAPACK auxiliary routine --
106* -- LAPACK is a software package provided by Univ. of Tennessee, --
107* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
108*
109* .. Scalar Arguments ..
110 LOGICAL FORWRD
111 INTEGER LDX, M, N
112* ..
113* .. Array Arguments ..
114 INTEGER K( * )
115 DOUBLE PRECISION X( LDX, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, II, IN, J
122 DOUBLE PRECISION TEMP
123* ..
124* .. Executable Statements ..
125*
126 IF( n.LE.1 )
127 $ RETURN
128*
129 DO 10 i = 1, n
130 k( i ) = -k( i )
131 10 CONTINUE
132*
133 IF( forwrd ) THEN
134*
135* Forward permutation
136*
137 DO 50 i = 1, n
138*
139 IF( k( i ).GT.0 )
140 $ GO TO 40
141*
142 j = i
143 k( j ) = -k( j )
144 in = k( j )
145*
146 20 CONTINUE
147 IF( k( in ).GT.0 )
148 $ GO TO 40
149*
150 DO 30 ii = 1, m
151 temp = x( ii, j )
152 x( ii, j ) = x( ii, in )
153 x( ii, in ) = temp
154 30 CONTINUE
155*
156 k( in ) = -k( in )
157 j = in
158 in = k( in )
159 GO TO 20
160*
161 40 CONTINUE
162*
163 50 CONTINUE
164*
165 ELSE
166*
167* Backward permutation
168*
169 DO 90 i = 1, n
170*
171 IF( k( i ).GT.0 )
172 $ GO TO 80
173*
174 k( i ) = -k( i )
175 j = k( i )
176 60 CONTINUE
177 IF( j.EQ.i )
178 $ GO TO 80
179*
180 DO 70 ii = 1, m
181 temp = x( ii, i )
182 x( ii, i ) = x( ii, j )
183 x( ii, j ) = temp
184 70 CONTINUE
185*
186 k( j ) = -k( j )
187 j = k( j )
188 GO TO 60
189*
190 80 CONTINUE
191*
192 90 CONTINUE
193*
194 END IF
195*
196 RETURN
197*
198* End of DLAPMT
199*

◆ dlaqp2()

subroutine dlaqp2 ( integer m,
integer n,
integer offset,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
double precision, dimension( * ) tau,
double precision, dimension( * ) vn1,
double precision, dimension( * ) vn2,
double precision, dimension( * ) work )

DLAQP2 computes a QR factorization with column pivoting of the matrix block.

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

Purpose:
!>
!> DLAQP2 computes a QR factorization with column pivoting of
!> the block A(OFFSET+1:M,1:N).
!> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0.
!>
[in]OFFSET
!>          OFFSET is INTEGER
!>          The number of rows of the matrix A that must be pivoted
!>          but no factorized. OFFSET >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
!>          the triangular factor obtained; the elements in block
!>          A(OFFSET+1:M,1:N) below the diagonal, together with the
!>          array TAU, represent the orthogonal matrix Q as a product of
!>          elementary reflectors. Block A(1:OFFSET,1:N) has been
!>          accordingly pivoted, but no factorized.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
!>          to the front of A*P (a leading column); if JPVT(i) = 0,
!>          the i-th column of A is a free column.
!>          On exit, if JPVT(i) = k, then the i-th column of A*P
!>          was the k-th column of A.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the exact column norms.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA
Partial column norm updating strategy modified on April 2011 Z. Drmac and Z. Bujanovic, Dept. of Mathematics, University of Zagreb, Croatia.
References:
LAPACK Working Note 176 [PDF]

Definition at line 147 of file dlaqp2.f.

149*
150* -- LAPACK auxiliary routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER LDA, M, N, OFFSET
156* ..
157* .. Array Arguments ..
158 INTEGER JPVT( * )
159 DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
160 $ WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO, ONE
167 parameter( zero = 0.0d+0, one = 1.0d+0 )
168* ..
169* .. Local Scalars ..
170 INTEGER I, ITEMP, J, MN, OFFPI, PVT
171 DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
172* ..
173* .. External Subroutines ..
174 EXTERNAL dlarf, dlarfg, dswap
175* ..
176* .. Intrinsic Functions ..
177 INTRINSIC abs, max, min, sqrt
178* ..
179* .. External Functions ..
180 INTEGER IDAMAX
181 DOUBLE PRECISION DLAMCH, DNRM2
182 EXTERNAL idamax, dlamch, dnrm2
183* ..
184* .. Executable Statements ..
185*
186 mn = min( m-offset, n )
187 tol3z = sqrt(dlamch('Epsilon'))
188*
189* Compute factorization.
190*
191 DO 20 i = 1, mn
192*
193 offpi = offset + i
194*
195* Determine ith pivot column and swap if necessary.
196*
197 pvt = ( i-1 ) + idamax( n-i+1, vn1( i ), 1 )
198*
199 IF( pvt.NE.i ) THEN
200 CALL dswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
201 itemp = jpvt( pvt )
202 jpvt( pvt ) = jpvt( i )
203 jpvt( i ) = itemp
204 vn1( pvt ) = vn1( i )
205 vn2( pvt ) = vn2( i )
206 END IF
207*
208* Generate elementary reflector H(i).
209*
210 IF( offpi.LT.m ) THEN
211 CALL dlarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1,
212 $ tau( i ) )
213 ELSE
214 CALL dlarfg( 1, a( m, i ), a( m, i ), 1, tau( i ) )
215 END IF
216*
217 IF( i.LT.n ) THEN
218*
219* Apply H(i)**T to A(offset+i:m,i+1:n) from the left.
220*
221 aii = a( offpi, i )
222 a( offpi, i ) = one
223 CALL dlarf( 'Left', m-offpi+1, n-i, a( offpi, i ), 1,
224 $ tau( i ), a( offpi, i+1 ), lda, work( 1 ) )
225 a( offpi, i ) = aii
226 END IF
227*
228* Update partial column norms.
229*
230 DO 10 j = i + 1, n
231 IF( vn1( j ).NE.zero ) THEN
232*
233* NOTE: The following 4 lines follow from the analysis in
234* Lapack Working Note 176.
235*
236 temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2
237 temp = max( temp, zero )
238 temp2 = temp*( vn1( j ) / vn2( j ) )**2
239 IF( temp2 .LE. tol3z ) THEN
240 IF( offpi.LT.m ) THEN
241 vn1( j ) = dnrm2( m-offpi, a( offpi+1, j ), 1 )
242 vn2( j ) = vn1( j )
243 ELSE
244 vn1( j ) = zero
245 vn2( j ) = zero
246 END IF
247 ELSE
248 vn1( j ) = vn1( j )*sqrt( temp )
249 END IF
250 END IF
251 10 CONTINUE
252*
253 20 CONTINUE
254*
255 RETURN
256*
257* End of DLAQP2
258*
dlarf
subroutine dlarf(side, m, n, v, incv, tau, c, ldc, work)
DLARF applies an elementary reflector to a general rectangular matrix.
Definition dlarf.f:124
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82

◆ dlaqps()

subroutine dlaqps ( integer m,
integer n,
integer offset,
integer nb,
integer kb,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
double precision, dimension( * ) tau,
double precision, dimension( * ) vn1,
double precision, dimension( * ) vn2,
double precision, dimension( * ) auxv,
double precision, dimension( ldf, * ) f,
integer ldf )

DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.

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

Purpose:
!>
!> DLAQPS computes a step of QR factorization with column pivoting
!> of a real M-by-N matrix A by using Blas-3.  It tries to factorize
!> NB columns from A starting from the row OFFSET+1, and updates all
!> of the matrix with Blas-3 xGEMM.
!>
!> In some cases, due to catastrophic cancellations, it cannot
!> factorize NB columns.  Hence, the actual number of factorized
!> columns is returned in KB.
!>
!> Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0
!>
[in]OFFSET
!>          OFFSET is INTEGER
!>          The number of rows of A that have been factorized in
!>          previous steps.
!>
[in]NB
!>          NB is INTEGER
!>          The number of columns to factorize.
!>
[out]KB
!>          KB is INTEGER
!>          The number of columns actually factorized.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, block A(OFFSET+1:M,1:KB) is the triangular
!>          factor obtained and block A(1:OFFSET,1:N) has been
!>          accordingly pivoted, but no factorized.
!>          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
!>          been updated.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
[in,out]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          JPVT(I) = K <==> Column K of the full matrix A has been
!>          permuted into position I in AP.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (KB)
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the exact column norms.
!>
[in,out]AUXV
!>          AUXV is DOUBLE PRECISION array, dimension (NB)
!>          Auxiliary vector.
!>
[in,out]F
!>          F is DOUBLE PRECISION array, dimension (LDF,NB)
!>          Matrix F**T = L*Y**T*A.
!>
[in]LDF
!>          LDF is INTEGER
!>          The leading dimension of the array F. LDF >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA
Partial column norm updating strategy modified on April 2011 Z. Drmac and Z. Bujanovic, Dept. of Mathematics, University of Zagreb, Croatia.
References:
LAPACK Working Note 176 [PDF]

Definition at line 175 of file dlaqps.f.

177*
178* -- LAPACK auxiliary routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 INTEGER KB, LDA, LDF, M, N, NB, OFFSET
184* ..
185* .. Array Arguments ..
186 INTEGER JPVT( * )
187 DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
188 $ VN1( * ), VN2( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO, ONE
195 parameter( zero = 0.0d+0, one = 1.0d+0 )
196* ..
197* .. Local Scalars ..
198 INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
199 DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z
200* ..
201* .. External Subroutines ..
202 EXTERNAL dgemm, dgemv, dlarfg, dswap
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC abs, dble, max, min, nint, sqrt
206* ..
207* .. External Functions ..
208 INTEGER IDAMAX
209 DOUBLE PRECISION DLAMCH, DNRM2
210 EXTERNAL idamax, dlamch, dnrm2
211* ..
212* .. Executable Statements ..
213*
214 lastrk = min( m, n+offset )
215 lsticc = 0
216 k = 0
217 tol3z = sqrt(dlamch('Epsilon'))
218*
219* Beginning of while loop.
220*
221 10 CONTINUE
222 IF( ( k.LT.nb ) .AND. ( lsticc.EQ.0 ) ) THEN
223 k = k + 1
224 rk = offset + k
225*
226* Determine ith pivot column and swap if necessary
227*
228 pvt = ( k-1 ) + idamax( n-k+1, vn1( k ), 1 )
229 IF( pvt.NE.k ) THEN
230 CALL dswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
231 CALL dswap( k-1, f( pvt, 1 ), ldf, f( k, 1 ), ldf )
232 itemp = jpvt( pvt )
233 jpvt( pvt ) = jpvt( k )
234 jpvt( k ) = itemp
235 vn1( pvt ) = vn1( k )
236 vn2( pvt ) = vn2( k )
237 END IF
238*
239* Apply previous Householder reflectors to column K:
240* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T.
241*
242 IF( k.GT.1 ) THEN
243 CALL dgemv( 'No transpose', m-rk+1, k-1, -one, a( rk, 1 ),
244 $ lda, f( k, 1 ), ldf, one, a( rk, k ), 1 )
245 END IF
246*
247* Generate elementary reflector H(k).
248*
249 IF( rk.LT.m ) THEN
250 CALL dlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) )
251 ELSE
252 CALL dlarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) )
253 END IF
254*
255 akk = a( rk, k )
256 a( rk, k ) = one
257*
258* Compute Kth column of F:
259*
260* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K).
261*
262 IF( k.LT.n ) THEN
263 CALL dgemv( 'Transpose', m-rk+1, n-k, tau( k ),
264 $ a( rk, k+1 ), lda, a( rk, k ), 1, zero,
265 $ f( k+1, k ), 1 )
266 END IF
267*
268* Padding F(1:K,K) with zeros.
269*
270 DO 20 j = 1, k
271 f( j, k ) = zero
272 20 CONTINUE
273*
274* Incremental updating of F:
275* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T
276* *A(RK:M,K).
277*
278 IF( k.GT.1 ) THEN
279 CALL dgemv( 'Transpose', m-rk+1, k-1, -tau( k ), a( rk, 1 ),
280 $ lda, a( rk, k ), 1, zero, auxv( 1 ), 1 )
281*
282 CALL dgemv( 'No transpose', n, k-1, one, f( 1, 1 ), ldf,
283 $ auxv( 1 ), 1, one, f( 1, k ), 1 )
284 END IF
285*
286* Update the current row of A:
287* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T.
288*
289 IF( k.LT.n ) THEN
290 CALL dgemv( 'No transpose', n-k, k, -one, f( k+1, 1 ), ldf,
291 $ a( rk, 1 ), lda, one, a( rk, k+1 ), lda )
292 END IF
293*
294* Update partial column norms.
295*
296 IF( rk.LT.lastrk ) THEN
297 DO 30 j = k + 1, n
298 IF( vn1( j ).NE.zero ) THEN
299*
300* NOTE: The following 4 lines follow from the analysis in
301* Lapack Working Note 176.
302*
303 temp = abs( a( rk, j ) ) / vn1( j )
304 temp = max( zero, ( one+temp )*( one-temp ) )
305 temp2 = temp*( vn1( j ) / vn2( j ) )**2
306 IF( temp2 .LE. tol3z ) THEN
307 vn2( j ) = dble( lsticc )
308 lsticc = j
309 ELSE
310 vn1( j ) = vn1( j )*sqrt( temp )
311 END IF
312 END IF
313 30 CONTINUE
314 END IF
315*
316 a( rk, k ) = akk
317*
318* End of while loop.
319*
320 GO TO 10
321 END IF
322 kb = k
323 rk = offset + kb
324*
325* Apply the block reflector to the rest of the matrix:
326* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
327* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T.
328*
329 IF( kb.LT.min( n, m-offset ) ) THEN
330 CALL dgemm( 'No transpose', 'Transpose', m-rk, n-kb, kb, -one,
331 $ a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf, one,
332 $ a( rk+1, kb+1 ), lda )
333 END IF
334*
335* Recomputation of difficult columns.
336*
337 40 CONTINUE
338 IF( lsticc.GT.0 ) THEN
339 itemp = nint( vn2( lsticc ) )
340 vn1( lsticc ) = dnrm2( m-rk, a( rk+1, lsticc ), 1 )
341*
342* NOTE: The computation of VN1( LSTICC ) relies on the fact that
343* SNRM2 does not fail on vectors with norm below the value of
344* SQRT(DLAMCH('S'))
345*
346 vn2( lsticc ) = vn1( lsticc )
347 lsticc = itemp
348 GO TO 40
349 END IF
350*
351 RETURN
352*
353* End of DLAQPS
354*

◆ dlaqr0()

subroutine dlaqr0 ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) work,
integer lwork,
integer info )

DLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.

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

Purpose:
!>
!>    DLAQR0 computes the eigenvalues of a Hessenberg matrix H
!>    and, optionally, the matrices T and Z from the Schur decomposition
!>    H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!>    Schur form), and Z is the orthogonal matrix of Schur vectors.
!>
!>    Optionally Z may be postmultiplied into an input orthogonal
!>    matrix Q so that this routine can give the Schur factorization
!>    of a matrix A which has been reduced to the Hessenberg form H
!>    by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>          = .TRUE. : the full Schur form T is required;
!>          = .FALSE.: only eigenvalues are required.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          = .TRUE. : the matrix of Schur vectors Z is required;
!>          = .FALSE.: Schur vectors are not required.
!>
[in]N
!>          N is INTEGER
!>           The order of the matrix H.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>           It is assumed that H is already upper triangular in rows
!>           and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
!>           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
!>           previous call to DGEBAL, and then passed to DGEHRD when the
!>           matrix output by DGEBAL is reduced to Hessenberg form.
!>           Otherwise, ILO and IHI should be set to 1 and N,
!>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
!>           If N = 0, then ILO = 1 and IHI = 0.
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>           On entry, the upper Hessenberg matrix H.
!>           On exit, if INFO = 0 and WANTT is .TRUE., then H contains
!>           the upper quasi-triangular matrix T from the Schur
!>           decomposition (the Schur form); 2-by-2 diagonal blocks
!>           (corresponding to complex conjugate pairs of eigenvalues)
!>           are returned in standard form, with H(i,i) = H(i+1,i+1)
!>           and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is
!>           .FALSE., then the contents of H are unspecified on exit.
!>           (The output value of H when INFO > 0 is given under the
!>           description of INFO below.)
!>
!>           This subroutine may explicitly set H(i,j) = 0 for i > j and
!>           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
!>
[in]LDH
!>          LDH is INTEGER
!>           The leading dimension of the array H. LDH >= max(1,N).
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (IHI)
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (IHI)
!>           The real and imaginary parts, respectively, of the computed
!>           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)
!>           and WI(ILO:IHI). If two eigenvalues are computed as a
!>           complex conjugate pair, they are stored in consecutive
!>           elements of WR and WI, say the i-th and (i+1)th, with
!>           WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then
!>           the eigenvalues are stored in the same order as on the
!>           diagonal of the Schur form returned in H, with
!>           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
!>           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
!>           WI(i+1) = -WI(i).
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>           Specify the rows of Z to which transformations must be
!>           applied if WANTZ is .TRUE..
!>           1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,IHI)
!>           If WANTZ is .FALSE., then Z is not referenced.
!>           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
!>           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
!>           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
!>           (The output value of Z when INFO > 0 is given under
!>           the description of INFO below.)
!>
[in]LDZ
!>          LDZ is INTEGER
!>           The leading dimension of the array Z.  if WANTZ is .TRUE.
!>           then LDZ >= MAX(1,IHIZ).  Otherwise, LDZ >= 1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension LWORK
!>           On exit, if LWORK = -1, WORK(1) returns an estimate of
!>           the optimal value for LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK.  LWORK >= max(1,N)
!>           is sufficient, but LWORK typically as large as 6*N may
!>           be required for optimal performance.  A workspace query
!>           to determine the optimal workspace size is recommended.
!>
!>           If LWORK = -1, then DLAQR0 does a workspace query.
!>           In this case, DLAQR0 checks the input parameters and
!>           estimates the optimal workspace size for the given
!>           values of N, ILO and IHI.  The estimate is returned
!>           in WORK(1).  No error message related to LWORK is
!>           issued by XERBLA.  Neither H nor Z are accessed.
!>
[out]INFO
!>          INFO is INTEGER
!>             = 0:  successful exit
!>             > 0:  if INFO = i, DLAQR0 failed to compute all of
!>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
!>                and WI contain those eigenvalues which have been
!>                successfully computed.  (Failures are rare.)
!>
!>                If INFO > 0 and WANT is .FALSE., then on exit,
!>                the remaining unconverged eigenvalues are the eigen-
!>                values of the upper Hessenberg matrix rows and
!>                columns ILO through INFO of the final, output
!>                value of H.
!>
!>                If INFO > 0 and WANTT is .TRUE., then on exit
!>
!>           (*)  (initial value of H)*U  = U*(final value of H)
!>
!>                where U is an orthogonal matrix.  The final
!>                value of H is upper Hessenberg and quasi-triangular
!>                in rows and columns INFO+1 through IHI.
!>
!>                If INFO > 0 and WANTZ is .TRUE., then on exit
!>
!>                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
!>                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
!>
!>                where U is the orthogonal matrix in (*) (regard-
!>                less of the value of WANTT.)
!>
!>                If INFO > 0 and WANTZ is .FALSE., then Z is not
!>                accessed.
!>
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA
References:
 K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
 Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
 Performance, SIAM Journal of Matrix Analysis, volume 23, pages
 929--947, 2002.

K. Braman, R. Byers and R. Mathias, The Multi-Shift QR Algorithm Part II: Aggressive Early Deflation, SIAM Journal of Matrix Analysis, volume 23, pages 948–973, 2002.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 254 of file dlaqr0.f.

256*
257* -- LAPACK auxiliary routine --
258* -- LAPACK is a software package provided by Univ. of Tennessee, --
259* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
260*
261* .. Scalar Arguments ..
262 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
263 LOGICAL WANTT, WANTZ
264* ..
265* .. Array Arguments ..
266 DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
267 $ Z( LDZ, * )
268* ..
269*
270* ================================================================
271*
272* .. Parameters ..
273*
274* ==== Matrices of order NTINY or smaller must be processed by
275* . DLAHQR because of insufficient subdiagonal scratch space.
276* . (This is a hard limit.) ====
277 INTEGER NTINY
278 parameter( ntiny = 15 )
279*
280* ==== Exceptional deflation windows: try to cure rare
281* . slow convergence by varying the size of the
282* . deflation window after KEXNW iterations. ====
283 INTEGER KEXNW
284 parameter( kexnw = 5 )
285*
286* ==== Exceptional shifts: try to cure rare slow convergence
287* . with ad-hoc exceptional shifts every KEXSH iterations.
288* . ====
289 INTEGER KEXSH
290 parameter( kexsh = 6 )
291*
292* ==== The constants WILK1 and WILK2 are used to form the
293* . exceptional shifts. ====
294 DOUBLE PRECISION WILK1, WILK2
295 parameter( wilk1 = 0.75d0, wilk2 = -0.4375d0 )
296 DOUBLE PRECISION ZERO, ONE
297 parameter( zero = 0.0d0, one = 1.0d0 )
298* ..
299* .. Local Scalars ..
300 DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
301 INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
302 $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
303 $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
304 $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
305 LOGICAL SORTED
306 CHARACTER JBCMPZ*2
307* ..
308* .. External Functions ..
309 INTEGER ILAENV
310 EXTERNAL ilaenv
311* ..
312* .. Local Arrays ..
313 DOUBLE PRECISION ZDUM( 1, 1 )
314* ..
315* .. External Subroutines ..
316 EXTERNAL dlacpy, dlahqr, dlanv2, dlaqr3, dlaqr4, dlaqr5
317* ..
318* .. Intrinsic Functions ..
319 INTRINSIC abs, dble, int, max, min, mod
320* ..
321* .. Executable Statements ..
322 info = 0
323*
324* ==== Quick return for N = 0: nothing to do. ====
325*
326 IF( n.EQ.0 ) THEN
327 work( 1 ) = one
328 RETURN
329 END IF
330*
331 IF( n.LE.ntiny ) THEN
332*
333* ==== Tiny matrices must use DLAHQR. ====
334*
335 lwkopt = 1
336 IF( lwork.NE.-1 )
337 $ CALL dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,
338 $ iloz, ihiz, z, ldz, info )
339 ELSE
340*
341* ==== Use small bulge multi-shift QR with aggressive early
342* . deflation on larger-than-tiny matrices. ====
343*
344* ==== Hope for the best. ====
345*
346 info = 0
347*
348* ==== Set up job flags for ILAENV. ====
349*
350 IF( wantt ) THEN
351 jbcmpz( 1: 1 ) = 'S'
352 ELSE
353 jbcmpz( 1: 1 ) = 'E'
354 END IF
355 IF( wantz ) THEN
356 jbcmpz( 2: 2 ) = 'V'
357 ELSE
358 jbcmpz( 2: 2 ) = 'N'
359 END IF
360*
361* ==== NWR = recommended deflation window size. At this
362* . point, N .GT. NTINY = 15, so there is enough
363* . subdiagonal workspace for NWR.GE.2 as required.
364* . (In fact, there is enough subdiagonal space for
365* . NWR.GE.4.) ====
366*
367 nwr = ilaenv( 13, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork )
368 nwr = max( 2, nwr )
369 nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
370*
371* ==== NSR = recommended number of simultaneous shifts.
372* . At this point N .GT. NTINY = 15, so there is at
373* . enough subdiagonal workspace for NSR to be even
374* . and greater than or equal to two as required. ====
375*
376 nsr = ilaenv( 15, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork )
377 nsr = min( nsr, ( n-3 ) / 6, ihi-ilo )
378 nsr = max( 2, nsr-mod( nsr, 2 ) )
379*
380* ==== Estimate optimal workspace ====
381*
382* ==== Workspace query call to DLAQR3 ====
383*
384 CALL dlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,
385 $ ihiz, z, ldz, ls, ld, wr, wi, h, ldh, n, h, ldh,
386 $ n, h, ldh, work, -1 )
387*
388* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
389*
390 lwkopt = max( 3*nsr / 2, int( work( 1 ) ) )
391*
392* ==== Quick return in case of workspace query. ====
393*
394 IF( lwork.EQ.-1 ) THEN
395 work( 1 ) = dble( lwkopt )
396 RETURN
397 END IF
398*
399* ==== DLAHQR/DLAQR0 crossover point ====
400*
401 nmin = ilaenv( 12, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork )
402 nmin = max( ntiny, nmin )
403*
404* ==== Nibble crossover point ====
405*
406 nibble = ilaenv( 14, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork )
407 nibble = max( 0, nibble )
408*
409* ==== Accumulate reflections during ttswp? Use block
410* . 2-by-2 structure during matrix-matrix multiply? ====
411*
412 kacc22 = ilaenv( 16, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork )
413 kacc22 = max( 0, kacc22 )
414 kacc22 = min( 2, kacc22 )
415*
416* ==== NWMAX = the largest possible deflation window for
417* . which there is sufficient workspace. ====
418*
419 nwmax = min( ( n-1 ) / 3, lwork / 2 )
420 nw = nwmax
421*
422* ==== NSMAX = the Largest number of simultaneous shifts
423* . for which there is sufficient workspace. ====
424*
425 nsmax = min( ( n-3 ) / 6, 2*lwork / 3 )
426 nsmax = nsmax - mod( nsmax, 2 )
427*
428* ==== NDFL: an iteration count restarted at deflation. ====
429*
430 ndfl = 1
431*
432* ==== ITMAX = iteration limit ====
433*
434 itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) )
435*
436* ==== Last row and column in the active block ====
437*
438 kbot = ihi
439*
440* ==== Main Loop ====
441*
442 DO 80 it = 1, itmax
443*
444* ==== Done when KBOT falls below ILO ====
445*
446 IF( kbot.LT.ilo )
447 $ GO TO 90
448*
449* ==== Locate active block ====
450*
451 DO 10 k = kbot, ilo + 1, -1
452 IF( h( k, k-1 ).EQ.zero )
453 $ GO TO 20
454 10 CONTINUE
455 k = ilo
456 20 CONTINUE
457 ktop = k
458*
459* ==== Select deflation window size:
460* . Typical Case:
461* . If possible and advisable, nibble the entire
462* . active block. If not, use size MIN(NWR,NWMAX)
463* . or MIN(NWR+1,NWMAX) depending upon which has
464* . the smaller corresponding subdiagonal entry
465* . (a heuristic).
466* .
467* . Exceptional Case:
468* . If there have been no deflations in KEXNW or
469* . more iterations, then vary the deflation window
470* . size. At first, because, larger windows are,
471* . in general, more powerful than smaller ones,
472* . rapidly increase the window to the maximum possible.
473* . Then, gradually reduce the window size. ====
474*
475 nh = kbot - ktop + 1
476 nwupbd = min( nh, nwmax )
477 IF( ndfl.LT.kexnw ) THEN
478 nw = min( nwupbd, nwr )
479 ELSE
480 nw = min( nwupbd, 2*nw )
481 END IF
482 IF( nw.LT.nwmax ) THEN
483 IF( nw.GE.nh-1 ) THEN
484 nw = nh
485 ELSE
486 kwtop = kbot - nw + 1
487 IF( abs( h( kwtop, kwtop-1 ) ).GT.
488 $ abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1
489 END IF
490 END IF
491 IF( ndfl.LT.kexnw ) THEN
492 ndec = -1
493 ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN
494 ndec = ndec + 1
495 IF( nw-ndec.LT.2 )
496 $ ndec = 0
497 nw = nw - ndec
498 END IF
499*
500* ==== Aggressive early deflation:
501* . split workspace under the subdiagonal into
502* . - an nw-by-nw work array V in the lower
503* . left-hand-corner,
504* . - an NW-by-at-least-NW-but-more-is-better
505* . (NW-by-NHO) horizontal work array along
506* . the bottom edge,
507* . - an at-least-NW-but-more-is-better (NHV-by-NW)
508* . vertical work array along the left-hand-edge.
509* . ====
510*
511 kv = n - nw + 1
512 kt = nw + 1
513 nho = ( n-nw-1 ) - kt + 1
514 kwv = nw + 2
515 nve = ( n-nw ) - kwv + 1
516*
517* ==== Aggressive early deflation ====
518*
519 CALL dlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,
520 $ ihiz, z, ldz, ls, ld, wr, wi, h( kv, 1 ), ldh,
521 $ nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,
522 $ work, lwork )
523*
524* ==== Adjust KBOT accounting for new deflations. ====
525*
526 kbot = kbot - ld
527*
528* ==== KS points to the shifts. ====
529*
530 ks = kbot - ls + 1
531*
532* ==== Skip an expensive QR sweep if there is a (partly
533* . heuristic) reason to expect that many eigenvalues
534* . will deflate without it. Here, the QR sweep is
535* . skipped if many eigenvalues have just been deflated
536* . or if the remaining active block is small.
537*
538 IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot-
539 $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN
540*
541* ==== NS = nominal number of simultaneous shifts.
542* . This may be lowered (slightly) if DLAQR3
543* . did not provide that many shifts. ====
544*
545 ns = min( nsmax, nsr, max( 2, kbot-ktop ) )
546 ns = ns - mod( ns, 2 )
547*
548* ==== If there have been no deflations
549* . in a multiple of KEXSH iterations,
550* . then try exceptional shifts.
551* . Otherwise use shifts provided by
552* . DLAQR3 above or from the eigenvalues
553* . of a trailing principal submatrix. ====
554*
555 IF( mod( ndfl, kexsh ).EQ.0 ) THEN
556 ks = kbot - ns + 1
557 DO 30 i = kbot, max( ks+1, ktop+2 ), -2
558 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
559 aa = wilk1*ss + h( i, i )
560 bb = ss
561 cc = wilk2*ss
562 dd = aa
563 CALL dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),
564 $ wr( i ), wi( i ), cs, sn )
565 30 CONTINUE
566 IF( ks.EQ.ktop ) THEN
567 wr( ks+1 ) = h( ks+1, ks+1 )
568 wi( ks+1 ) = zero
569 wr( ks ) = wr( ks+1 )
570 wi( ks ) = wi( ks+1 )
571 END IF
572 ELSE
573*
574* ==== Got NS/2 or fewer shifts? Use DLAQR4 or
575* . DLAHQR on a trailing principal submatrix to
576* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6,
577* . there is enough space below the subdiagonal
578* . to fit an NS-by-NS scratch array.) ====
579*
580 IF( kbot-ks+1.LE.ns / 2 ) THEN
581 ks = kbot - ns + 1
582 kt = n - ns + 1
583 CALL dlacpy( 'A', ns, ns, h( ks, ks ), ldh,
584 $ h( kt, 1 ), ldh )
585 IF( ns.GT.nmin ) THEN
586 CALL dlaqr4( .false., .false., ns, 1, ns,
587 $ h( kt, 1 ), ldh, wr( ks ),
588 $ wi( ks ), 1, 1, zdum, 1, work,
589 $ lwork, inf )
590 ELSE
591 CALL dlahqr( .false., .false., ns, 1, ns,
592 $ h( kt, 1 ), ldh, wr( ks ),
593 $ wi( ks ), 1, 1, zdum, 1, inf )
594 END IF
595 ks = ks + inf
596*
597* ==== In case of a rare QR failure use
598* . eigenvalues of the trailing 2-by-2
599* . principal submatrix. ====
600*
601 IF( ks.GE.kbot ) THEN
602 aa = h( kbot-1, kbot-1 )
603 cc = h( kbot, kbot-1 )
604 bb = h( kbot-1, kbot )
605 dd = h( kbot, kbot )
606 CALL dlanv2( aa, bb, cc, dd, wr( kbot-1 ),
607 $ wi( kbot-1 ), wr( kbot ),
608 $ wi( kbot ), cs, sn )
609 ks = kbot - 1
610 END IF
611 END IF
612*
613 IF( kbot-ks+1.GT.ns ) THEN
614*
615* ==== Sort the shifts (Helps a little)
616* . Bubble sort keeps complex conjugate
617* . pairs together. ====
618*
619 sorted = .false.
620 DO 50 k = kbot, ks + 1, -1
621 IF( sorted )
622 $ GO TO 60
623 sorted = .true.
624 DO 40 i = ks, k - 1
625 IF( abs( wr( i ) )+abs( wi( i ) ).LT.
626 $ abs( wr( i+1 ) )+abs( wi( i+1 ) ) ) THEN
627 sorted = .false.
628*
629 swap = wr( i )
630 wr( i ) = wr( i+1 )
631 wr( i+1 ) = swap
632*
633 swap = wi( i )
634 wi( i ) = wi( i+1 )
635 wi( i+1 ) = swap
636 END IF
637 40 CONTINUE
638 50 CONTINUE
639 60 CONTINUE
640 END IF
641*
642* ==== Shuffle shifts into pairs of real shifts
643* . and pairs of complex conjugate shifts
644* . assuming complex conjugate shifts are
645* . already adjacent to one another. (Yes,
646* . they are.) ====
647*
648 DO 70 i = kbot, ks + 2, -2
649 IF( wi( i ).NE.-wi( i-1 ) ) THEN
650*
651 swap = wr( i )
652 wr( i ) = wr( i-1 )
653 wr( i-1 ) = wr( i-2 )
654 wr( i-2 ) = swap
655*
656 swap = wi( i )
657 wi( i ) = wi( i-1 )
658 wi( i-1 ) = wi( i-2 )
659 wi( i-2 ) = swap
660 END IF
661 70 CONTINUE
662 END IF
663*
664* ==== If there are only two shifts and both are
665* . real, then use only one. ====
666*
667 IF( kbot-ks+1.EQ.2 ) THEN
668 IF( wi( kbot ).EQ.zero ) THEN
669 IF( abs( wr( kbot )-h( kbot, kbot ) ).LT.
670 $ abs( wr( kbot-1 )-h( kbot, kbot ) ) ) THEN
671 wr( kbot-1 ) = wr( kbot )
672 ELSE
673 wr( kbot ) = wr( kbot-1 )
674 END IF
675 END IF
676 END IF
677*
678* ==== Use up to NS of the the smallest magnitude
679* . shifts. If there aren't NS shifts available,
680* . then use them all, possibly dropping one to
681* . make the number of shifts even. ====
682*
683 ns = min( ns, kbot-ks+1 )
684 ns = ns - mod( ns, 2 )
685 ks = kbot - ns + 1
686*
687* ==== Small-bulge multi-shift QR sweep:
688* . split workspace under the subdiagonal into
689* . - a KDU-by-KDU work array U in the lower
690* . left-hand-corner,
691* . - a KDU-by-at-least-KDU-but-more-is-better
692* . (KDU-by-NHo) horizontal work array WH along
693* . the bottom edge,
694* . - and an at-least-KDU-but-more-is-better-by-KDU
695* . (NVE-by-KDU) vertical work WV arrow along
696* . the left-hand-edge. ====
697*
698 kdu = 2*ns
699 ku = n - kdu + 1
700 kwh = kdu + 1
701 nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1
702 kwv = kdu + 4
703 nve = n - kdu - kwv + 1
704*
705* ==== Small-bulge multi-shift QR sweep ====
706*
707 CALL dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,
708 $ wr( ks ), wi( ks ), h, ldh, iloz, ihiz, z,
709 $ ldz, work, 3, h( ku, 1 ), ldh, nve,
710 $ h( kwv, 1 ), ldh, nho, h( ku, kwh ), ldh )
711 END IF
712*
713* ==== Note progress (or the lack of it). ====
714*
715 IF( ld.GT.0 ) THEN
716 ndfl = 1
717 ELSE
718 ndfl = ndfl + 1
719 END IF
720*
721* ==== End of main loop ====
722 80 CONTINUE
723*
724* ==== Iteration limit exceeded. Set INFO to show where
725* . the problem occurred and exit. ====
726*
727 info = kbot
728 90 CONTINUE
729 END IF
730*
731* ==== Return the optimal value of LWORK. ====
732*
733 work( 1 ) = dble( lwkopt )
734*
735* ==== End of DLAQR0 ====
736*
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162
dlahqr
subroutine dlahqr(wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, info)
DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix,...
Definition dlahqr.f:207
dlaqr4
subroutine dlaqr4(wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, iloz, ihiz, z, ldz, work, lwork, info)
DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur de...
Definition dlaqr4.f:263
dlaqr5
subroutine dlaqr5(wantt, wantz, kacc22, n, ktop, kbot, nshfts, sr, si, h, ldh, iloz, ihiz, z, ldz, v, ldv, u, ldu, nv, wv, ldwv, nh, wh, ldwh)
DLAQR5 performs a single small-bulge multi-shift QR sweep.
Definition dlaqr5.f:265
dlaqr3
subroutine dlaqr3(wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sr, si, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate...
Definition dlaqr3.f:275
swap
#define swap(a, b, tmp)
Definition macros.h:40

◆ dlaqr1()

subroutine dlaqr1 ( integer n,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision sr1,
double precision si1,
double precision sr2,
double precision si2,
double precision, dimension( * ) v )

DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and specified shifts.

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

Purpose:
!>
!>      Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a
!>      scalar multiple of the first column of the product
!>
!>      (*)  K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
!>
!>      scaling to avoid overflows and most underflows. It
!>      is assumed that either
!>
!>              1) sr1 = sr2 and si1 = -si2
!>          or
!>              2) si1 = si2 = 0.
!>
!>      This is useful for starting double implicit shift bulges
!>      in the QR algorithm.
!>
Parameters
[in]N
!>          N is INTEGER
!>              Order of the matrix H. N must be either 2 or 3.
!>
[in]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>              The 2-by-2 or 3-by-3 matrix H in (*).
!>
[in]LDH
!>          LDH is INTEGER
!>              The leading dimension of H as declared in
!>              the calling procedure.  LDH >= N
!>
[in]SR1
!>          SR1 is DOUBLE PRECISION
!>
[in]SI1
!>          SI1 is DOUBLE PRECISION
!>
[in]SR2
!>          SR2 is DOUBLE PRECISION
!>
[in]SI2
!>          SI2 is DOUBLE PRECISION
!>              The shifts in (*).
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (N)
!>              A scalar multiple of the first column of the
!>              matrix K in (*).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA

Definition at line 120 of file dlaqr1.f.

121*
122* -- LAPACK auxiliary routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 DOUBLE PRECISION SI1, SI2, SR1, SR2
128 INTEGER LDH, N
129* ..
130* .. Array Arguments ..
131 DOUBLE PRECISION H( LDH, * ), V( * )
132* ..
133*
134* ================================================================
135*
136* .. Parameters ..
137 DOUBLE PRECISION ZERO
138 parameter( zero = 0.0d0 )
139* ..
140* .. Local Scalars ..
141 DOUBLE PRECISION H21S, H31S, S
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC abs
145* ..
146* .. Executable Statements ..
147*
148* Quick return if possible
149*
150 IF( n.NE.2 .AND. n.NE.3 ) THEN
151 RETURN
152 END IF
153*
154 IF( n.EQ.2 ) THEN
155 s = abs( h( 1, 1 )-sr2 ) + abs( si2 ) + abs( h( 2, 1 ) )
156 IF( s.EQ.zero ) THEN
157 v( 1 ) = zero
158 v( 2 ) = zero
159 ELSE
160 h21s = h( 2, 1 ) / s
161 v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-sr1 )*
162 $ ( ( h( 1, 1 )-sr2 ) / s ) - si1*( si2 / s )
163 v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-sr1-sr2 )
164 END IF
165 ELSE
166 s = abs( h( 1, 1 )-sr2 ) + abs( si2 ) + abs( h( 2, 1 ) ) +
167 $ abs( h( 3, 1 ) )
168 IF( s.EQ.zero ) THEN
169 v( 1 ) = zero
170 v( 2 ) = zero
171 v( 3 ) = zero
172 ELSE
173 h21s = h( 2, 1 ) / s
174 h31s = h( 3, 1 ) / s
175 v( 1 ) = ( h( 1, 1 )-sr1 )*( ( h( 1, 1 )-sr2 ) / s ) -
176 $ si1*( si2 / s ) + h( 1, 2 )*h21s + h( 1, 3 )*h31s
177 v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-sr1-sr2 ) +
178 $ h( 2, 3 )*h31s
179 v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-sr1-sr2 ) +
180 $ h21s*h( 3, 2 )
181 END IF
182 END IF

◆ dlaqr2()

subroutine dlaqr2 ( logical wantt,
logical wantz,
integer n,
integer ktop,
integer kbot,
integer nw,
double precision, dimension( ldh, * ) h,
integer ldh,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
integer ns,
integer nd,
double precision, dimension( * ) sr,
double precision, dimension( * ) si,
double precision, dimension( ldv, * ) v,
integer ldv,
integer nh,
double precision, dimension( ldt, * ) t,
integer ldt,
integer nv,
double precision, dimension( ldwv, * ) wv,
integer ldwv,
double precision, dimension( * ) work,
integer lwork )

DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).

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

Purpose:
!>
!>    DLAQR2 is identical to DLAQR3 except that it avoids
!>    recursion by calling DLAHQR instead of DLAQR4.
!>
!>    Aggressive early deflation:
!>
!>    This subroutine accepts as input an upper Hessenberg matrix
!>    H and performs an orthogonal similarity transformation
!>    designed to detect and deflate fully converged eigenvalues from
!>    a trailing principal submatrix.  On output H has been over-
!>    written by a new Hessenberg matrix that is a perturbation of
!>    an orthogonal similarity transformation of H.  It is to be
!>    hoped that the final version of H has many zero subdiagonal
!>    entries.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>          If .TRUE., then the Hessenberg matrix H is fully updated
!>          so that the quasi-triangular Schur factor may be
!>          computed (in cooperation with the calling subroutine).
!>          If .FALSE., then only enough of H is updated to preserve
!>          the eigenvalues.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          If .TRUE., then the orthogonal matrix Z is updated so
!>          so that the orthogonal Schur factor may be computed
!>          (in cooperation with the calling subroutine).
!>          If .FALSE., then Z is not referenced.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H and (if WANTZ is .TRUE.) the
!>          order of the orthogonal matrix Z.
!>
[in]KTOP
!>          KTOP is INTEGER
!>          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
!>          KBOT and KTOP together determine an isolated block
!>          along the diagonal of the Hessenberg matrix.
!>
[in]KBOT
!>          KBOT is INTEGER
!>          It is assumed without a check that either
!>          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
!>          determine an isolated block along the diagonal of the
!>          Hessenberg matrix.
!>
[in]NW
!>          NW is INTEGER
!>          Deflation window size.  1 <= NW <= (KBOT-KTOP+1).
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          On input the initial N-by-N section of H stores the
!>          Hessenberg matrix undergoing aggressive early deflation.
!>          On output H has been transformed by an orthogonal
!>          similarity transformation, perturbed, and the returned
!>          to Hessenberg form that (it is to be hoped) has some
!>          zero subdiagonal entries.
!>
[in]LDH
!>          LDH is INTEGER
!>          Leading dimension of H just as declared in the calling
!>          subroutine.  N <= LDH
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>          Specify the rows of Z to which transformations must be
!>          applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
!>          IF WANTZ is .TRUE., then on output, the orthogonal
!>          similarity transformation mentioned above has been
!>          accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
!>          If WANTZ is .FALSE., then Z is unreferenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of Z just as declared in the
!>          calling subroutine.  1 <= LDZ.
!>
[out]NS
!>          NS is INTEGER
!>          The number of unconverged (ie approximate) eigenvalues
!>          returned in SR and SI that may be used as shifts by the
!>          calling subroutine.
!>
[out]ND
!>          ND is INTEGER
!>          The number of converged eigenvalues uncovered by this
!>          subroutine.
!>
[out]SR
!>          SR is DOUBLE PRECISION array, dimension (KBOT)
!>
[out]SI
!>          SI is DOUBLE PRECISION array, dimension (KBOT)
!>          On output, the real and imaginary parts of approximate
!>          eigenvalues that may be used for shifts are stored in
!>          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
!>          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
!>          The real and imaginary parts of converged eigenvalues
!>          are stored in SR(KBOT-ND+1) through SR(KBOT) and
!>          SI(KBOT-ND+1) through SI(KBOT), respectively.
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,NW)
!>          An NW-by-NW work array.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V just as declared in the
!>          calling subroutine.  NW <= LDV
!>
[in]NH
!>          NH is INTEGER
!>          The number of columns of T.  NH >= NW.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,NW)
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of T just as declared in the
!>          calling subroutine.  NW <= LDT
!>
[in]NV
!>          NV is INTEGER
!>          The number of rows of work array WV available for
!>          workspace.  NV >= NW.
!>
[out]WV
!>          WV is DOUBLE PRECISION array, dimension (LDWV,NW)
!>
[in]LDWV
!>          LDWV is INTEGER
!>          The leading dimension of W just as declared in the
!>          calling subroutine.  NW <= LDV
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, WORK(1) is set to an estimate of the optimal value
!>          of LWORK for the given values of N, NW, KTOP and KBOT.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the work array WORK.  LWORK = 2*NW
!>          suffices, but greater efficiency may result from larger
!>          values of LWORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; DLAQR2
!>          only estimates the optimal workspace size for the given
!>          values of N, NW, KTOP and KBOT.  The estimate is returned
!>          in WORK(1).  No error message related to LWORK is issued
!>          by XERBLA.  Neither H nor Z are accessed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA

Definition at line 275 of file dlaqr2.f.

278*
279* -- LAPACK auxiliary routine --
280* -- LAPACK is a software package provided by Univ. of Tennessee, --
281* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
282*
283* .. Scalar Arguments ..
284 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
285 $ LDZ, LWORK, N, ND, NH, NS, NV, NW
286 LOGICAL WANTT, WANTZ
287* ..
288* .. Array Arguments ..
289 DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
290 $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
291 $ Z( LDZ, * )
292* ..
293*
294* ================================================================
295* .. Parameters ..
296 DOUBLE PRECISION ZERO, ONE
297 parameter( zero = 0.0d0, one = 1.0d0 )
298* ..
299* .. Local Scalars ..
300 DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
301 $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
302 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
303 $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
304 $ LWKOPT
305 LOGICAL BULGE, SORTED
306* ..
307* .. External Functions ..
308 DOUBLE PRECISION DLAMCH
309 EXTERNAL dlamch
310* ..
311* .. External Subroutines ..
312 EXTERNAL dcopy, dgehrd, dgemm, dlabad, dlacpy, dlahqr,
313 $ dlanv2, dlarf, dlarfg, dlaset, dormhr, dtrexc
314* ..
315* .. Intrinsic Functions ..
316 INTRINSIC abs, dble, int, max, min, sqrt
317* ..
318* .. Executable Statements ..
319*
320* ==== Estimate optimal workspace. ====
321*
322 jw = min( nw, kbot-ktop+1 )
323 IF( jw.LE.2 ) THEN
324 lwkopt = 1
325 ELSE
326*
327* ==== Workspace query call to DGEHRD ====
328*
329 CALL dgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
330 lwk1 = int( work( 1 ) )
331*
332* ==== Workspace query call to DORMHR ====
333*
334 CALL dormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
335 $ work, -1, info )
336 lwk2 = int( work( 1 ) )
337*
338* ==== Optimal workspace ====
339*
340 lwkopt = jw + max( lwk1, lwk2 )
341 END IF
342*
343* ==== Quick return in case of workspace query. ====
344*
345 IF( lwork.EQ.-1 ) THEN
346 work( 1 ) = dble( lwkopt )
347 RETURN
348 END IF
349*
350* ==== Nothing to do ...
351* ... for an empty active block ... ====
352 ns = 0
353 nd = 0
354 work( 1 ) = one
355 IF( ktop.GT.kbot )
356 $ RETURN
357* ... nor for an empty deflation window. ====
358 IF( nw.LT.1 )
359 $ RETURN
360*
361* ==== Machine constants ====
362*
363 safmin = dlamch( 'SAFE MINIMUM' )
364 safmax = one / safmin
365 CALL dlabad( safmin, safmax )
366 ulp = dlamch( 'PRECISION' )
367 smlnum = safmin*( dble( n ) / ulp )
368*
369* ==== Setup deflation window ====
370*
371 jw = min( nw, kbot-ktop+1 )
372 kwtop = kbot - jw + 1
373 IF( kwtop.EQ.ktop ) THEN
374 s = zero
375 ELSE
376 s = h( kwtop, kwtop-1 )
377 END IF
378*
379 IF( kbot.EQ.kwtop ) THEN
380*
381* ==== 1-by-1 deflation window: not much to do ====
382*
383 sr( kwtop ) = h( kwtop, kwtop )
384 si( kwtop ) = zero
385 ns = 1
386 nd = 0
387 IF( abs( s ).LE.max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )
388 $ THEN
389 ns = 0
390 nd = 1
391 IF( kwtop.GT.ktop )
392 $ h( kwtop, kwtop-1 ) = zero
393 END IF
394 work( 1 ) = one
395 RETURN
396 END IF
397*
398* ==== Convert to spike-triangular form. (In case of a
399* . rare QR failure, this routine continues to do
400* . aggressive early deflation using that part of
401* . the deflation window that converged using INFQR
402* . here and there to keep track.) ====
403*
404 CALL dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
405 CALL dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
406*
407 CALL dlaset( 'A', jw, jw, zero, one, v, ldv )
408 CALL dlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),
409 $ si( kwtop ), 1, jw, v, ldv, infqr )
410*
411* ==== DTREXC needs a clean margin near the diagonal ====
412*
413 DO 10 j = 1, jw - 3
414 t( j+2, j ) = zero
415 t( j+3, j ) = zero
416 10 CONTINUE
417 IF( jw.GT.2 )
418 $ t( jw, jw-2 ) = zero
419*
420* ==== Deflation detection loop ====
421*
422 ns = jw
423 ilst = infqr + 1
424 20 CONTINUE
425 IF( ilst.LE.ns ) THEN
426 IF( ns.EQ.1 ) THEN
427 bulge = .false.
428 ELSE
429 bulge = t( ns, ns-1 ).NE.zero
430 END IF
431*
432* ==== Small spike tip test for deflation ====
433*
434 IF( .NOT.bulge ) THEN
435*
436* ==== Real eigenvalue ====
437*
438 foo = abs( t( ns, ns ) )
439 IF( foo.EQ.zero )
440 $ foo = abs( s )
441 IF( abs( s*v( 1, ns ) ).LE.max( smlnum, ulp*foo ) ) THEN
442*
443* ==== Deflatable ====
444*
445 ns = ns - 1
446 ELSE
447*
448* ==== Undeflatable. Move it up out of the way.
449* . (DTREXC can not fail in this case.) ====
450*
451 ifst = ns
452 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
453 $ info )
454 ilst = ilst + 1
455 END IF
456 ELSE
457*
458* ==== Complex conjugate pair ====
459*
460 foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*
461 $ sqrt( abs( t( ns-1, ns ) ) )
462 IF( foo.EQ.zero )
463 $ foo = abs( s )
464 IF( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) ).LE.
465 $ max( smlnum, ulp*foo ) ) THEN
466*
467* ==== Deflatable ====
468*
469 ns = ns - 2
470 ELSE
471*
472* ==== Undeflatable. Move them up out of the way.
473* . Fortunately, DTREXC does the right thing with
474* . ILST in case of a rare exchange failure. ====
475*
476 ifst = ns
477 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
478 $ info )
479 ilst = ilst + 2
480 END IF
481 END IF
482*
483* ==== End deflation detection loop ====
484*
485 GO TO 20
486 END IF
487*
488* ==== Return to Hessenberg form ====
489*
490 IF( ns.EQ.0 )
491 $ s = zero
492*
493 IF( ns.LT.jw ) THEN
494*
495* ==== sorting diagonal blocks of T improves accuracy for
496* . graded matrices. Bubble sort deals well with
497* . exchange failures. ====
498*
499 sorted = .false.
500 i = ns + 1
501 30 CONTINUE
502 IF( sorted )
503 $ GO TO 50
504 sorted = .true.
505*
506 kend = i - 1
507 i = infqr + 1
508 IF( i.EQ.ns ) THEN
509 k = i + 1
510 ELSE IF( t( i+1, i ).EQ.zero ) THEN
511 k = i + 1
512 ELSE
513 k = i + 2
514 END IF
515 40 CONTINUE
516 IF( k.LE.kend ) THEN
517 IF( k.EQ.i+1 ) THEN
518 evi = abs( t( i, i ) )
519 ELSE
520 evi = abs( t( i, i ) ) + sqrt( abs( t( i+1, i ) ) )*
521 $ sqrt( abs( t( i, i+1 ) ) )
522 END IF
523*
524 IF( k.EQ.kend ) THEN
525 evk = abs( t( k, k ) )
526 ELSE IF( t( k+1, k ).EQ.zero ) THEN
527 evk = abs( t( k, k ) )
528 ELSE
529 evk = abs( t( k, k ) ) + sqrt( abs( t( k+1, k ) ) )*
530 $ sqrt( abs( t( k, k+1 ) ) )
531 END IF
532*
533 IF( evi.GE.evk ) THEN
534 i = k
535 ELSE
536 sorted = .false.
537 ifst = i
538 ilst = k
539 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
540 $ info )
541 IF( info.EQ.0 ) THEN
542 i = ilst
543 ELSE
544 i = k
545 END IF
546 END IF
547 IF( i.EQ.kend ) THEN
548 k = i + 1
549 ELSE IF( t( i+1, i ).EQ.zero ) THEN
550 k = i + 1
551 ELSE
552 k = i + 2
553 END IF
554 GO TO 40
555 END IF
556 GO TO 30
557 50 CONTINUE
558 END IF
559*
560* ==== Restore shift/eigenvalue array from T ====
561*
562 i = jw
563 60 CONTINUE
564 IF( i.GE.infqr+1 ) THEN
565 IF( i.EQ.infqr+1 ) THEN
566 sr( kwtop+i-1 ) = t( i, i )
567 si( kwtop+i-1 ) = zero
568 i = i - 1
569 ELSE IF( t( i, i-1 ).EQ.zero ) THEN
570 sr( kwtop+i-1 ) = t( i, i )
571 si( kwtop+i-1 ) = zero
572 i = i - 1
573 ELSE
574 aa = t( i-1, i-1 )
575 cc = t( i, i-1 )
576 bb = t( i-1, i )
577 dd = t( i, i )
578 CALL dlanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),
579 $ si( kwtop+i-2 ), sr( kwtop+i-1 ),
580 $ si( kwtop+i-1 ), cs, sn )
581 i = i - 2
582 END IF
583 GO TO 60
584 END IF
585*
586 IF( ns.LT.jw .OR. s.EQ.zero ) THEN
587 IF( ns.GT.1 .AND. s.NE.zero ) THEN
588*
589* ==== Reflect spike back into lower triangle ====
590*
591 CALL dcopy( ns, v, ldv, work, 1 )
592 beta = work( 1 )
593 CALL dlarfg( ns, beta, work( 2 ), 1, tau )
594 work( 1 ) = one
595*
596 CALL dlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
597*
598 CALL dlarf( 'L', ns, jw, work, 1, tau, t, ldt,
599 $ work( jw+1 ) )
600 CALL dlarf( 'R', ns, ns, work, 1, tau, t, ldt,
601 $ work( jw+1 ) )
602 CALL dlarf( 'R', jw, ns, work, 1, tau, v, ldv,
603 $ work( jw+1 ) )
604*
605 CALL dgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
606 $ lwork-jw, info )
607 END IF
608*
609* ==== Copy updated reduced window into place ====
610*
611 IF( kwtop.GT.1 )
612 $ h( kwtop, kwtop-1 ) = s*v( 1, 1 )
613 CALL dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
614 CALL dcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
615 $ ldh+1 )
616*
617* ==== Accumulate orthogonal matrix in order update
618* . H and Z, if requested. ====
619*
620 IF( ns.GT.1 .AND. s.NE.zero )
621 $ CALL dormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
622 $ work( jw+1 ), lwork-jw, info )
623*
624* ==== Update vertical slab in H ====
625*
626 IF( wantt ) THEN
627 ltop = 1
628 ELSE
629 ltop = ktop
630 END IF
631 DO 70 krow = ltop, kwtop - 1, nv
632 kln = min( nv, kwtop-krow )
633 CALL dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
634 $ ldh, v, ldv, zero, wv, ldwv )
635 CALL dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
636 70 CONTINUE
637*
638* ==== Update horizontal slab in H ====
639*
640 IF( wantt ) THEN
641 DO 80 kcol = kbot + 1, n, nh
642 kln = min( nh, n-kcol+1 )
643 CALL dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
644 $ h( kwtop, kcol ), ldh, zero, t, ldt )
645 CALL dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
646 $ ldh )
647 80 CONTINUE
648 END IF
649*
650* ==== Update vertical slab in Z ====
651*
652 IF( wantz ) THEN
653 DO 90 krow = iloz, ihiz, nv
654 kln = min( nv, ihiz-krow+1 )
655 CALL dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
656 $ ldz, v, ldv, zero, wv, ldwv )
657 CALL dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
658 $ ldz )
659 90 CONTINUE
660 END IF
661 END IF
662*
663* ==== Return the number of deflations ... ====
664*
665 nd = jw - ns
666*
667* ==== ... and the number of shifts. (Subtracting
668* . INFQR from the spike length takes care
669* . of the case of a rare QR failure while
670* . calculating eigenvalues of the deflation
671* . window.) ====
672*
673 ns = ns - infqr
674*
675* ==== Return optimal workspace. ====
676*
677 work( 1 ) = dble( lwkopt )
678*
679* ==== End of DLAQR2 ====
680*
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
dgehrd
subroutine dgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
DGEHRD
Definition dgehrd.f:167
dtrexc
subroutine dtrexc(compq, n, t, ldt, q, ldq, ifst, ilst, work, info)
DTREXC
Definition dtrexc.f:148
dormhr
subroutine dormhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
DORMHR
Definition dormhr.f:178

◆ dlaqr3()

subroutine dlaqr3 ( logical wantt,
logical wantz,
integer n,
integer ktop,
integer kbot,
integer nw,
double precision, dimension( ldh, * ) h,
integer ldh,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
integer ns,
integer nd,
double precision, dimension( * ) sr,
double precision, dimension( * ) si,
double precision, dimension( ldv, * ) v,
integer ldv,
integer nh,
double precision, dimension( ldt, * ) t,
integer ldt,
integer nv,
double precision, dimension( ldwv, * ) wv,
integer ldwv,
double precision, dimension( * ) work,
integer lwork )

DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).

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

Purpose:
!>
!>    Aggressive early deflation:
!>
!>    DLAQR3 accepts as input an upper Hessenberg matrix
!>    H and performs an orthogonal similarity transformation
!>    designed to detect and deflate fully converged eigenvalues from
!>    a trailing principal submatrix.  On output H has been over-
!>    written by a new Hessenberg matrix that is a perturbation of
!>    an orthogonal similarity transformation of H.  It is to be
!>    hoped that the final version of H has many zero subdiagonal
!>    entries.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>          If .TRUE., then the Hessenberg matrix H is fully updated
!>          so that the quasi-triangular Schur factor may be
!>          computed (in cooperation with the calling subroutine).
!>          If .FALSE., then only enough of H is updated to preserve
!>          the eigenvalues.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          If .TRUE., then the orthogonal matrix Z is updated so
!>          so that the orthogonal Schur factor may be computed
!>          (in cooperation with the calling subroutine).
!>          If .FALSE., then Z is not referenced.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H and (if WANTZ is .TRUE.) the
!>          order of the orthogonal matrix Z.
!>
[in]KTOP
!>          KTOP is INTEGER
!>          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
!>          KBOT and KTOP together determine an isolated block
!>          along the diagonal of the Hessenberg matrix.
!>
[in]KBOT
!>          KBOT is INTEGER
!>          It is assumed without a check that either
!>          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
!>          determine an isolated block along the diagonal of the
!>          Hessenberg matrix.
!>
[in]NW
!>          NW is INTEGER
!>          Deflation window size.  1 <= NW <= (KBOT-KTOP+1).
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          On input the initial N-by-N section of H stores the
!>          Hessenberg matrix undergoing aggressive early deflation.
!>          On output H has been transformed by an orthogonal
!>          similarity transformation, perturbed, and the returned
!>          to Hessenberg form that (it is to be hoped) has some
!>          zero subdiagonal entries.
!>
[in]LDH
!>          LDH is INTEGER
!>          Leading dimension of H just as declared in the calling
!>          subroutine.  N <= LDH
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>          Specify the rows of Z to which transformations must be
!>          applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
!>          IF WANTZ is .TRUE., then on output, the orthogonal
!>          similarity transformation mentioned above has been
!>          accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
!>          If WANTZ is .FALSE., then Z is unreferenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of Z just as declared in the
!>          calling subroutine.  1 <= LDZ.
!>
[out]NS
!>          NS is INTEGER
!>          The number of unconverged (ie approximate) eigenvalues
!>          returned in SR and SI that may be used as shifts by the
!>          calling subroutine.
!>
[out]ND
!>          ND is INTEGER
!>          The number of converged eigenvalues uncovered by this
!>          subroutine.
!>
[out]SR
!>          SR is DOUBLE PRECISION array, dimension (KBOT)
!>
[out]SI
!>          SI is DOUBLE PRECISION array, dimension (KBOT)
!>          On output, the real and imaginary parts of approximate
!>          eigenvalues that may be used for shifts are stored in
!>          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
!>          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
!>          The real and imaginary parts of converged eigenvalues
!>          are stored in SR(KBOT-ND+1) through SR(KBOT) and
!>          SI(KBOT-ND+1) through SI(KBOT), respectively.
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,NW)
!>          An NW-by-NW work array.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of V just as declared in the
!>          calling subroutine.  NW <= LDV
!>
[in]NH
!>          NH is INTEGER
!>          The number of columns of T.  NH >= NW.
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,NW)
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of T just as declared in the
!>          calling subroutine.  NW <= LDT
!>
[in]NV
!>          NV is INTEGER
!>          The number of rows of work array WV available for
!>          workspace.  NV >= NW.
!>
[out]WV
!>          WV is DOUBLE PRECISION array, dimension (LDWV,NW)
!>
[in]LDWV
!>          LDWV is INTEGER
!>          The leading dimension of W just as declared in the
!>          calling subroutine.  NW <= LDV
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, WORK(1) is set to an estimate of the optimal value
!>          of LWORK for the given values of N, NW, KTOP and KBOT.
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the work array WORK.  LWORK = 2*NW
!>          suffices, but greater efficiency may result from larger
!>          values of LWORK.
!>
!>          If LWORK = -1, then a workspace query is assumed; DLAQR3
!>          only estimates the optimal workspace size for the given
!>          values of N, NW, KTOP and KBOT.  The estimate is returned
!>          in WORK(1).  No error message related to LWORK is issued
!>          by XERBLA.  Neither H nor Z are accessed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA

Definition at line 272 of file dlaqr3.f.

275*
276* -- LAPACK auxiliary routine --
277* -- LAPACK is a software package provided by Univ. of Tennessee, --
278* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
279*
280* .. Scalar Arguments ..
281 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
282 $ LDZ, LWORK, N, ND, NH, NS, NV, NW
283 LOGICAL WANTT, WANTZ
284* ..
285* .. Array Arguments ..
286 DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
287 $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
288 $ Z( LDZ, * )
289* ..
290*
291* ================================================================
292* .. Parameters ..
293 DOUBLE PRECISION ZERO, ONE
294 parameter( zero = 0.0d0, one = 1.0d0 )
295* ..
296* .. Local Scalars ..
297 DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
298 $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
299 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
300 $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
301 $ LWKOPT, NMIN
302 LOGICAL BULGE, SORTED
303* ..
304* .. External Functions ..
305 DOUBLE PRECISION DLAMCH
306 INTEGER ILAENV
307 EXTERNAL dlamch, ilaenv
308* ..
309* .. External Subroutines ..
310 EXTERNAL dcopy, dgehrd, dgemm, dlabad, dlacpy, dlahqr,
311 $ dlanv2, dlaqr4, dlarf, dlarfg, dlaset, dormhr,
312 $ dtrexc
313* ..
314* .. Intrinsic Functions ..
315 INTRINSIC abs, dble, int, max, min, sqrt
316* ..
317* .. Executable Statements ..
318*
319* ==== Estimate optimal workspace. ====
320*
321 jw = min( nw, kbot-ktop+1 )
322 IF( jw.LE.2 ) THEN
323 lwkopt = 1
324 ELSE
325*
326* ==== Workspace query call to DGEHRD ====
327*
328 CALL dgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
329 lwk1 = int( work( 1 ) )
330*
331* ==== Workspace query call to DORMHR ====
332*
333 CALL dormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
334 $ work, -1, info )
335 lwk2 = int( work( 1 ) )
336*
337* ==== Workspace query call to DLAQR4 ====
338*
339 CALL dlaqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,
340 $ v, ldv, work, -1, infqr )
341 lwk3 = int( work( 1 ) )
342*
343* ==== Optimal workspace ====
344*
345 lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 )
346 END IF
347*
348* ==== Quick return in case of workspace query. ====
349*
350 IF( lwork.EQ.-1 ) THEN
351 work( 1 ) = dble( lwkopt )
352 RETURN
353 END IF
354*
355* ==== Nothing to do ...
356* ... for an empty active block ... ====
357 ns = 0
358 nd = 0
359 work( 1 ) = one
360 IF( ktop.GT.kbot )
361 $ RETURN
362* ... nor for an empty deflation window. ====
363 IF( nw.LT.1 )
364 $ RETURN
365*
366* ==== Machine constants ====
367*
368 safmin = dlamch( 'SAFE MINIMUM' )
369 safmax = one / safmin
370 CALL dlabad( safmin, safmax )
371 ulp = dlamch( 'PRECISION' )
372 smlnum = safmin*( dble( n ) / ulp )
373*
374* ==== Setup deflation window ====
375*
376 jw = min( nw, kbot-ktop+1 )
377 kwtop = kbot - jw + 1
378 IF( kwtop.EQ.ktop ) THEN
379 s = zero
380 ELSE
381 s = h( kwtop, kwtop-1 )
382 END IF
383*
384 IF( kbot.EQ.kwtop ) THEN
385*
386* ==== 1-by-1 deflation window: not much to do ====
387*
388 sr( kwtop ) = h( kwtop, kwtop )
389 si( kwtop ) = zero
390 ns = 1
391 nd = 0
392 IF( abs( s ).LE.max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )
393 $ THEN
394 ns = 0
395 nd = 1
396 IF( kwtop.GT.ktop )
397 $ h( kwtop, kwtop-1 ) = zero
398 END IF
399 work( 1 ) = one
400 RETURN
401 END IF
402*
403* ==== Convert to spike-triangular form. (In case of a
404* . rare QR failure, this routine continues to do
405* . aggressive early deflation using that part of
406* . the deflation window that converged using INFQR
407* . here and there to keep track.) ====
408*
409 CALL dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
410 CALL dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
411*
412 CALL dlaset( 'A', jw, jw, zero, one, v, ldv )
413 nmin = ilaenv( 12, 'DLAQR3', 'SV', jw, 1, jw, lwork )
414 IF( jw.GT.nmin ) THEN
415 CALL dlaqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),
416 $ si( kwtop ), 1, jw, v, ldv, work, lwork, infqr )
417 ELSE
418 CALL dlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),
419 $ si( kwtop ), 1, jw, v, ldv, infqr )
420 END IF
421*
422* ==== DTREXC needs a clean margin near the diagonal ====
423*
424 DO 10 j = 1, jw - 3
425 t( j+2, j ) = zero
426 t( j+3, j ) = zero
427 10 CONTINUE
428 IF( jw.GT.2 )
429 $ t( jw, jw-2 ) = zero
430*
431* ==== Deflation detection loop ====
432*
433 ns = jw
434 ilst = infqr + 1
435 20 CONTINUE
436 IF( ilst.LE.ns ) THEN
437 IF( ns.EQ.1 ) THEN
438 bulge = .false.
439 ELSE
440 bulge = t( ns, ns-1 ).NE.zero
441 END IF
442*
443* ==== Small spike tip test for deflation ====
444*
445 IF( .NOT. bulge ) THEN
446*
447* ==== Real eigenvalue ====
448*
449 foo = abs( t( ns, ns ) )
450 IF( foo.EQ.zero )
451 $ foo = abs( s )
452 IF( abs( s*v( 1, ns ) ).LE.max( smlnum, ulp*foo ) ) THEN
453*
454* ==== Deflatable ====
455*
456 ns = ns - 1
457 ELSE
458*
459* ==== Undeflatable. Move it up out of the way.
460* . (DTREXC can not fail in this case.) ====
461*
462 ifst = ns
463 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
464 $ info )
465 ilst = ilst + 1
466 END IF
467 ELSE
468*
469* ==== Complex conjugate pair ====
470*
471 foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*
472 $ sqrt( abs( t( ns-1, ns ) ) )
473 IF( foo.EQ.zero )
474 $ foo = abs( s )
475 IF( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) ).LE.
476 $ max( smlnum, ulp*foo ) ) THEN
477*
478* ==== Deflatable ====
479*
480 ns = ns - 2
481 ELSE
482*
483* ==== Undeflatable. Move them up out of the way.
484* . Fortunately, DTREXC does the right thing with
485* . ILST in case of a rare exchange failure. ====
486*
487 ifst = ns
488 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
489 $ info )
490 ilst = ilst + 2
491 END IF
492 END IF
493*
494* ==== End deflation detection loop ====
495*
496 GO TO 20
497 END IF
498*
499* ==== Return to Hessenberg form ====
500*
501 IF( ns.EQ.0 )
502 $ s = zero
503*
504 IF( ns.LT.jw ) THEN
505*
506* ==== sorting diagonal blocks of T improves accuracy for
507* . graded matrices. Bubble sort deals well with
508* . exchange failures. ====
509*
510 sorted = .false.
511 i = ns + 1
512 30 CONTINUE
513 IF( sorted )
514 $ GO TO 50
515 sorted = .true.
516*
517 kend = i - 1
518 i = infqr + 1
519 IF( i.EQ.ns ) THEN
520 k = i + 1
521 ELSE IF( t( i+1, i ).EQ.zero ) THEN
522 k = i + 1
523 ELSE
524 k = i + 2
525 END IF
526 40 CONTINUE
527 IF( k.LE.kend ) THEN
528 IF( k.EQ.i+1 ) THEN
529 evi = abs( t( i, i ) )
530 ELSE
531 evi = abs( t( i, i ) ) + sqrt( abs( t( i+1, i ) ) )*
532 $ sqrt( abs( t( i, i+1 ) ) )
533 END IF
534*
535 IF( k.EQ.kend ) THEN
536 evk = abs( t( k, k ) )
537 ELSE IF( t( k+1, k ).EQ.zero ) THEN
538 evk = abs( t( k, k ) )
539 ELSE
540 evk = abs( t( k, k ) ) + sqrt( abs( t( k+1, k ) ) )*
541 $ sqrt( abs( t( k, k+1 ) ) )
542 END IF
543*
544 IF( evi.GE.evk ) THEN
545 i = k
546 ELSE
547 sorted = .false.
548 ifst = i
549 ilst = k
550 CALL dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,
551 $ info )
552 IF( info.EQ.0 ) THEN
553 i = ilst
554 ELSE
555 i = k
556 END IF
557 END IF
558 IF( i.EQ.kend ) THEN
559 k = i + 1
560 ELSE IF( t( i+1, i ).EQ.zero ) THEN
561 k = i + 1
562 ELSE
563 k = i + 2
564 END IF
565 GO TO 40
566 END IF
567 GO TO 30
568 50 CONTINUE
569 END IF
570*
571* ==== Restore shift/eigenvalue array from T ====
572*
573 i = jw
574 60 CONTINUE
575 IF( i.GE.infqr+1 ) THEN
576 IF( i.EQ.infqr+1 ) THEN
577 sr( kwtop+i-1 ) = t( i, i )
578 si( kwtop+i-1 ) = zero
579 i = i - 1
580 ELSE IF( t( i, i-1 ).EQ.zero ) THEN
581 sr( kwtop+i-1 ) = t( i, i )
582 si( kwtop+i-1 ) = zero
583 i = i - 1
584 ELSE
585 aa = t( i-1, i-1 )
586 cc = t( i, i-1 )
587 bb = t( i-1, i )
588 dd = t( i, i )
589 CALL dlanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),
590 $ si( kwtop+i-2 ), sr( kwtop+i-1 ),
591 $ si( kwtop+i-1 ), cs, sn )
592 i = i - 2
593 END IF
594 GO TO 60
595 END IF
596*
597 IF( ns.LT.jw .OR. s.EQ.zero ) THEN
598 IF( ns.GT.1 .AND. s.NE.zero ) THEN
599*
600* ==== Reflect spike back into lower triangle ====
601*
602 CALL dcopy( ns, v, ldv, work, 1 )
603 beta = work( 1 )
604 CALL dlarfg( ns, beta, work( 2 ), 1, tau )
605 work( 1 ) = one
606*
607 CALL dlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
608*
609 CALL dlarf( 'L', ns, jw, work, 1, tau, t, ldt,
610 $ work( jw+1 ) )
611 CALL dlarf( 'R', ns, ns, work, 1, tau, t, ldt,
612 $ work( jw+1 ) )
613 CALL dlarf( 'R', jw, ns, work, 1, tau, v, ldv,
614 $ work( jw+1 ) )
615*
616 CALL dgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
617 $ lwork-jw, info )
618 END IF
619*
620* ==== Copy updated reduced window into place ====
621*
622 IF( kwtop.GT.1 )
623 $ h( kwtop, kwtop-1 ) = s*v( 1, 1 )
624 CALL dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
625 CALL dcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
626 $ ldh+1 )
627*
628* ==== Accumulate orthogonal matrix in order update
629* . H and Z, if requested. ====
630*
631 IF( ns.GT.1 .AND. s.NE.zero )
632 $ CALL dormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
633 $ work( jw+1 ), lwork-jw, info )
634*
635* ==== Update vertical slab in H ====
636*
637 IF( wantt ) THEN
638 ltop = 1
639 ELSE
640 ltop = ktop
641 END IF
642 DO 70 krow = ltop, kwtop - 1, nv
643 kln = min( nv, kwtop-krow )
644 CALL dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
645 $ ldh, v, ldv, zero, wv, ldwv )
646 CALL dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
647 70 CONTINUE
648*
649* ==== Update horizontal slab in H ====
650*
651 IF( wantt ) THEN
652 DO 80 kcol = kbot + 1, n, nh
653 kln = min( nh, n-kcol+1 )
654 CALL dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
655 $ h( kwtop, kcol ), ldh, zero, t, ldt )
656 CALL dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
657 $ ldh )
658 80 CONTINUE
659 END IF
660*
661* ==== Update vertical slab in Z ====
662*
663 IF( wantz ) THEN
664 DO 90 krow = iloz, ihiz, nv
665 kln = min( nv, ihiz-krow+1 )
666 CALL dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
667 $ ldz, v, ldv, zero, wv, ldwv )
668 CALL dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
669 $ ldz )
670 90 CONTINUE
671 END IF
672 END IF
673*
674* ==== Return the number of deflations ... ====
675*
676 nd = jw - ns
677*
678* ==== ... and the number of shifts. (Subtracting
679* . INFQR from the spike length takes care
680* . of the case of a rare QR failure while
681* . calculating eigenvalues of the deflation
682* . window.) ====
683*
684 ns = ns - infqr
685*
686* ==== Return optimal workspace. ====
687*
688 work( 1 ) = dble( lwkopt )
689*
690* ==== End of DLAQR3 ====
691*

◆ dlaqr4()

subroutine dlaqr4 ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
double precision, dimension( ldh, * ) h,
integer ldh,
double precision, dimension( * ) wr,
double precision, dimension( * ) wi,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) work,
integer lwork,
integer info )

DLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.

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

Purpose:
!>
!>    DLAQR4 implements one level of recursion for DLAQR0.
!>    It is a complete implementation of the small bulge multi-shift
!>    QR algorithm.  It may be called by DLAQR0 and, for large enough
!>    deflation window size, it may be called by DLAQR3.  This
!>    subroutine is identical to DLAQR0 except that it calls DLAQR2
!>    instead of DLAQR3.
!>
!>    DLAQR4 computes the eigenvalues of a Hessenberg matrix H
!>    and, optionally, the matrices T and Z from the Schur decomposition
!>    H = Z T Z**T, where T is an upper quasi-triangular matrix (the
!>    Schur form), and Z is the orthogonal matrix of Schur vectors.
!>
!>    Optionally Z may be postmultiplied into an input orthogonal
!>    matrix Q so that this routine can give the Schur factorization
!>    of a matrix A which has been reduced to the Hessenberg form H
!>    by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>          = .TRUE. : the full Schur form T is required;
!>          = .FALSE.: only eigenvalues are required.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>          = .TRUE. : the matrix of Schur vectors Z is required;
!>          = .FALSE.: Schur vectors are not required.
!>
[in]N
!>          N is INTEGER
!>           The order of the matrix H.  N >= 0.
!>
[in]ILO
!>          ILO is INTEGER
!>
[in]IHI
!>          IHI is INTEGER
!>           It is assumed that H is already upper triangular in rows
!>           and columns 1:ILO-1 and IHI+1:N and, if ILO > 1,
!>           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
!>           previous call to DGEBAL, and then passed to DGEHRD when the
!>           matrix output by DGEBAL is reduced to Hessenberg form.
!>           Otherwise, ILO and IHI should be set to 1 and N,
!>           respectively.  If N > 0, then 1 <= ILO <= IHI <= N.
!>           If N = 0, then ILO = 1 and IHI = 0.
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>           On entry, the upper Hessenberg matrix H.
!>           On exit, if INFO = 0 and WANTT is .TRUE., then H contains
!>           the upper quasi-triangular matrix T from the Schur
!>           decomposition (the Schur form); 2-by-2 diagonal blocks
!>           (corresponding to complex conjugate pairs of eigenvalues)
!>           are returned in standard form, with H(i,i) = H(i+1,i+1)
!>           and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is
!>           .FALSE., then the contents of H are unspecified on exit.
!>           (The output value of H when INFO > 0 is given under the
!>           description of INFO below.)
!>
!>           This subroutine may explicitly set H(i,j) = 0 for i > j and
!>           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
!>
[in]LDH
!>          LDH is INTEGER
!>           The leading dimension of the array H. LDH >= max(1,N).
!>
[out]WR
!>          WR is DOUBLE PRECISION array, dimension (IHI)
!>
[out]WI
!>          WI is DOUBLE PRECISION array, dimension (IHI)
!>           The real and imaginary parts, respectively, of the computed
!>           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)
!>           and WI(ILO:IHI). If two eigenvalues are computed as a
!>           complex conjugate pair, they are stored in consecutive
!>           elements of WR and WI, say the i-th and (i+1)th, with
!>           WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then
!>           the eigenvalues are stored in the same order as on the
!>           diagonal of the Schur form returned in H, with
!>           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
!>           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
!>           WI(i+1) = -WI(i).
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>           Specify the rows of Z to which transformations must be
!>           applied if WANTZ is .TRUE..
!>           1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,IHI)
!>           If WANTZ is .FALSE., then Z is not referenced.
!>           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
!>           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
!>           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
!>           (The output value of Z when INFO > 0 is given under
!>           the description of INFO below.)
!>
[in]LDZ
!>          LDZ is INTEGER
!>           The leading dimension of the array Z.  if WANTZ is .TRUE.
!>           then LDZ >= MAX(1,IHIZ).  Otherwise, LDZ >= 1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension LWORK
!>           On exit, if LWORK = -1, WORK(1) returns an estimate of
!>           the optimal value for LWORK.
!>
[in]LWORK
!>          LWORK is INTEGER
!>           The dimension of the array WORK.  LWORK >= max(1,N)
!>           is sufficient, but LWORK typically as large as 6*N may
!>           be required for optimal performance.  A workspace query
!>           to determine the optimal workspace size is recommended.
!>
!>           If LWORK = -1, then DLAQR4 does a workspace query.
!>           In this case, DLAQR4 checks the input parameters and
!>           estimates the optimal workspace size for the given
!>           values of N, ILO and IHI.  The estimate is returned
!>           in WORK(1).  No error message related to LWORK is
!>           issued by XERBLA.  Neither H nor Z are accessed.
!>
[out]INFO
!>          INFO is INTEGER
!>             = 0:  successful exit
!>             > 0:  if INFO = i, DLAQR4 failed to compute all of
!>                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
!>                and WI contain those eigenvalues which have been
!>                successfully computed.  (Failures are rare.)
!>
!>                If INFO > 0 and WANT is .FALSE., then on exit,
!>                the remaining unconverged eigenvalues are the eigen-
!>                values of the upper Hessenberg matrix rows and
!>                columns ILO through INFO of the final, output
!>                value of H.
!>
!>                If INFO > 0 and WANTT is .TRUE., then on exit
!>
!>           (*)  (initial value of H)*U  = U*(final value of H)
!>
!>                where U is a orthogonal matrix.  The final
!>                value of  H is upper Hessenberg and triangular in
!>                rows and columns INFO+1 through IHI.
!>
!>                If INFO > 0 and WANTZ is .TRUE., then on exit
!>
!>                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
!>                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
!>
!>                where U is the orthogonal matrix in (*) (regard-
!>                less of the value of WANTT.)
!>
!>                If INFO > 0 and WANTZ is .FALSE., then Z is not
!>                accessed.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA
References:
 K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
 Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
 Performance, SIAM Journal of Matrix Analysis, volume 23, pages
 929--947, 2002.

K. Braman, R. Byers and R. Mathias, The Multi-Shift QR Algorithm Part II: Aggressive Early Deflation, SIAM Journal of Matrix Analysis, volume 23, pages 948–973, 2002.

Definition at line 261 of file dlaqr4.f.

263*
264* -- LAPACK auxiliary routine --
265* -- LAPACK is a software package provided by Univ. of Tennessee, --
266* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
267*
268* .. Scalar Arguments ..
269 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
270 LOGICAL WANTT, WANTZ
271* ..
272* .. Array Arguments ..
273 DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
274 $ Z( LDZ, * )
275* ..
276*
277* ================================================================
278* .. Parameters ..
279*
280* ==== Matrices of order NTINY or smaller must be processed by
281* . DLAHQR because of insufficient subdiagonal scratch space.
282* . (This is a hard limit.) ====
283 INTEGER NTINY
284 parameter( ntiny = 15 )
285*
286* ==== Exceptional deflation windows: try to cure rare
287* . slow convergence by varying the size of the
288* . deflation window after KEXNW iterations. ====
289 INTEGER KEXNW
290 parameter( kexnw = 5 )
291*
292* ==== Exceptional shifts: try to cure rare slow convergence
293* . with ad-hoc exceptional shifts every KEXSH iterations.
294* . ====
295 INTEGER KEXSH
296 parameter( kexsh = 6 )
297*
298* ==== The constants WILK1 and WILK2 are used to form the
299* . exceptional shifts. ====
300 DOUBLE PRECISION WILK1, WILK2
301 parameter( wilk1 = 0.75d0, wilk2 = -0.4375d0 )
302 DOUBLE PRECISION ZERO, ONE
303 parameter( zero = 0.0d0, one = 1.0d0 )
304* ..
305* .. Local Scalars ..
306 DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
307 INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
308 $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
309 $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS,
310 $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD
311 LOGICAL SORTED
312 CHARACTER JBCMPZ*2
313* ..
314* .. External Functions ..
315 INTEGER ILAENV
316 EXTERNAL ilaenv
317* ..
318* .. Local Arrays ..
319 DOUBLE PRECISION ZDUM( 1, 1 )
320* ..
321* .. External Subroutines ..
322 EXTERNAL dlacpy, dlahqr, dlanv2, dlaqr2, dlaqr5
323* ..
324* .. Intrinsic Functions ..
325 INTRINSIC abs, dble, int, max, min, mod
326* ..
327* .. Executable Statements ..
328 info = 0
329*
330* ==== Quick return for N = 0: nothing to do. ====
331*
332 IF( n.EQ.0 ) THEN
333 work( 1 ) = one
334 RETURN
335 END IF
336*
337 IF( n.LE.ntiny ) THEN
338*
339* ==== Tiny matrices must use DLAHQR. ====
340*
341 lwkopt = 1
342 IF( lwork.NE.-1 )
343 $ CALL dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,
344 $ iloz, ihiz, z, ldz, info )
345 ELSE
346*
347* ==== Use small bulge multi-shift QR with aggressive early
348* . deflation on larger-than-tiny matrices. ====
349*
350* ==== Hope for the best. ====
351*
352 info = 0
353*
354* ==== Set up job flags for ILAENV. ====
355*
356 IF( wantt ) THEN
357 jbcmpz( 1: 1 ) = 'S'
358 ELSE
359 jbcmpz( 1: 1 ) = 'E'
360 END IF
361 IF( wantz ) THEN
362 jbcmpz( 2: 2 ) = 'V'
363 ELSE
364 jbcmpz( 2: 2 ) = 'N'
365 END IF
366*
367* ==== NWR = recommended deflation window size. At this
368* . point, N .GT. NTINY = 15, so there is enough
369* . subdiagonal workspace for NWR.GE.2 as required.
370* . (In fact, there is enough subdiagonal space for
371* . NWR.GE.4.) ====
372*
373 nwr = ilaenv( 13, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
374 nwr = max( 2, nwr )
375 nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr )
376*
377* ==== NSR = recommended number of simultaneous shifts.
378* . At this point N .GT. NTINY = 15, so there is at
379* . enough subdiagonal workspace for NSR to be even
380* . and greater than or equal to two as required. ====
381*
382 nsr = ilaenv( 15, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
383 nsr = min( nsr, ( n-3 ) / 6, ihi-ilo )
384 nsr = max( 2, nsr-mod( nsr, 2 ) )
385*
386* ==== Estimate optimal workspace ====
387*
388* ==== Workspace query call to DLAQR2 ====
389*
390 CALL dlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,
391 $ ihiz, z, ldz, ls, ld, wr, wi, h, ldh, n, h, ldh,
392 $ n, h, ldh, work, -1 )
393*
394* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ====
395*
396 lwkopt = max( 3*nsr / 2, int( work( 1 ) ) )
397*
398* ==== Quick return in case of workspace query. ====
399*
400 IF( lwork.EQ.-1 ) THEN
401 work( 1 ) = dble( lwkopt )
402 RETURN
403 END IF
404*
405* ==== DLAHQR/DLAQR0 crossover point ====
406*
407 nmin = ilaenv( 12, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
408 nmin = max( ntiny, nmin )
409*
410* ==== Nibble crossover point ====
411*
412 nibble = ilaenv( 14, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
413 nibble = max( 0, nibble )
414*
415* ==== Accumulate reflections during ttswp? Use block
416* . 2-by-2 structure during matrix-matrix multiply? ====
417*
418 kacc22 = ilaenv( 16, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork )
419 kacc22 = max( 0, kacc22 )
420 kacc22 = min( 2, kacc22 )
421*
422* ==== NWMAX = the largest possible deflation window for
423* . which there is sufficient workspace. ====
424*
425 nwmax = min( ( n-1 ) / 3, lwork / 2 )
426 nw = nwmax
427*
428* ==== NSMAX = the Largest number of simultaneous shifts
429* . for which there is sufficient workspace. ====
430*
431 nsmax = min( ( n-3 ) / 6, 2*lwork / 3 )
432 nsmax = nsmax - mod( nsmax, 2 )
433*
434* ==== NDFL: an iteration count restarted at deflation. ====
435*
436 ndfl = 1
437*
438* ==== ITMAX = iteration limit ====
439*
440 itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) )
441*
442* ==== Last row and column in the active block ====
443*
444 kbot = ihi
445*
446* ==== Main Loop ====
447*
448 DO 80 it = 1, itmax
449*
450* ==== Done when KBOT falls below ILO ====
451*
452 IF( kbot.LT.ilo )
453 $ GO TO 90
454*
455* ==== Locate active block ====
456*
457 DO 10 k = kbot, ilo + 1, -1
458 IF( h( k, k-1 ).EQ.zero )
459 $ GO TO 20
460 10 CONTINUE
461 k = ilo
462 20 CONTINUE
463 ktop = k
464*
465* ==== Select deflation window size:
466* . Typical Case:
467* . If possible and advisable, nibble the entire
468* . active block. If not, use size MIN(NWR,NWMAX)
469* . or MIN(NWR+1,NWMAX) depending upon which has
470* . the smaller corresponding subdiagonal entry
471* . (a heuristic).
472* .
473* . Exceptional Case:
474* . If there have been no deflations in KEXNW or
475* . more iterations, then vary the deflation window
476* . size. At first, because, larger windows are,
477* . in general, more powerful than smaller ones,
478* . rapidly increase the window to the maximum possible.
479* . Then, gradually reduce the window size. ====
480*
481 nh = kbot - ktop + 1
482 nwupbd = min( nh, nwmax )
483 IF( ndfl.LT.kexnw ) THEN
484 nw = min( nwupbd, nwr )
485 ELSE
486 nw = min( nwupbd, 2*nw )
487 END IF
488 IF( nw.LT.nwmax ) THEN
489 IF( nw.GE.nh-1 ) THEN
490 nw = nh
491 ELSE
492 kwtop = kbot - nw + 1
493 IF( abs( h( kwtop, kwtop-1 ) ).GT.
494 $ abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + 1
495 END IF
496 END IF
497 IF( ndfl.LT.kexnw ) THEN
498 ndec = -1
499 ELSE IF( ndec.GE.0 .OR. nw.GE.nwupbd ) THEN
500 ndec = ndec + 1
501 IF( nw-ndec.LT.2 )
502 $ ndec = 0
503 nw = nw - ndec
504 END IF
505*
506* ==== Aggressive early deflation:
507* . split workspace under the subdiagonal into
508* . - an nw-by-nw work array V in the lower
509* . left-hand-corner,
510* . - an NW-by-at-least-NW-but-more-is-better
511* . (NW-by-NHO) horizontal work array along
512* . the bottom edge,
513* . - an at-least-NW-but-more-is-better (NHV-by-NW)
514* . vertical work array along the left-hand-edge.
515* . ====
516*
517 kv = n - nw + 1
518 kt = nw + 1
519 nho = ( n-nw-1 ) - kt + 1
520 kwv = nw + 2
521 nve = ( n-nw ) - kwv + 1
522*
523* ==== Aggressive early deflation ====
524*
525 CALL dlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,
526 $ ihiz, z, ldz, ls, ld, wr, wi, h( kv, 1 ), ldh,
527 $ nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,
528 $ work, lwork )
529*
530* ==== Adjust KBOT accounting for new deflations. ====
531*
532 kbot = kbot - ld
533*
534* ==== KS points to the shifts. ====
535*
536 ks = kbot - ls + 1
537*
538* ==== Skip an expensive QR sweep if there is a (partly
539* . heuristic) reason to expect that many eigenvalues
540* . will deflate without it. Here, the QR sweep is
541* . skipped if many eigenvalues have just been deflated
542* . or if the remaining active block is small.
543*
544 IF( ( ld.EQ.0 ) .OR. ( ( 100*ld.LE.nw*nibble ) .AND. ( kbot-
545 $ ktop+1.GT.min( nmin, nwmax ) ) ) ) THEN
546*
547* ==== NS = nominal number of simultaneous shifts.
548* . This may be lowered (slightly) if DLAQR2
549* . did not provide that many shifts. ====
550*
551 ns = min( nsmax, nsr, max( 2, kbot-ktop ) )
552 ns = ns - mod( ns, 2 )
553*
554* ==== If there have been no deflations
555* . in a multiple of KEXSH iterations,
556* . then try exceptional shifts.
557* . Otherwise use shifts provided by
558* . DLAQR2 above or from the eigenvalues
559* . of a trailing principal submatrix. ====
560*
561 IF( mod( ndfl, kexsh ).EQ.0 ) THEN
562 ks = kbot - ns + 1
563 DO 30 i = kbot, max( ks+1, ktop+2 ), -2
564 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) )
565 aa = wilk1*ss + h( i, i )
566 bb = ss
567 cc = wilk2*ss
568 dd = aa
569 CALL dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),
570 $ wr( i ), wi( i ), cs, sn )
571 30 CONTINUE
572 IF( ks.EQ.ktop ) THEN
573 wr( ks+1 ) = h( ks+1, ks+1 )
574 wi( ks+1 ) = zero
575 wr( ks ) = wr( ks+1 )
576 wi( ks ) = wi( ks+1 )
577 END IF
578 ELSE
579*
580* ==== Got NS/2 or fewer shifts? Use DLAHQR
581* . on a trailing principal submatrix to
582* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6,
583* . there is enough space below the subdiagonal
584* . to fit an NS-by-NS scratch array.) ====
585*
586 IF( kbot-ks+1.LE.ns / 2 ) THEN
587 ks = kbot - ns + 1
588 kt = n - ns + 1
589 CALL dlacpy( 'A', ns, ns, h( ks, ks ), ldh,
590 $ h( kt, 1 ), ldh )
591 CALL dlahqr( .false., .false., ns, 1, ns,
592 $ h( kt, 1 ), ldh, wr( ks ), wi( ks ),
593 $ 1, 1, zdum, 1, inf )
594 ks = ks + inf
595*
596* ==== In case of a rare QR failure use
597* . eigenvalues of the trailing 2-by-2
598* . principal submatrix. ====
599*
600 IF( ks.GE.kbot ) THEN
601 aa = h( kbot-1, kbot-1 )
602 cc = h( kbot, kbot-1 )
603 bb = h( kbot-1, kbot )
604 dd = h( kbot, kbot )
605 CALL dlanv2( aa, bb, cc, dd, wr( kbot-1 ),
606 $ wi( kbot-1 ), wr( kbot ),
607 $ wi( kbot ), cs, sn )
608 ks = kbot - 1
609 END IF
610 END IF
611*
612 IF( kbot-ks+1.GT.ns ) THEN
613*
614* ==== Sort the shifts (Helps a little)
615* . Bubble sort keeps complex conjugate
616* . pairs together. ====
617*
618 sorted = .false.
619 DO 50 k = kbot, ks + 1, -1
620 IF( sorted )
621 $ GO TO 60
622 sorted = .true.
623 DO 40 i = ks, k - 1
624 IF( abs( wr( i ) )+abs( wi( i ) ).LT.
625 $ abs( wr( i+1 ) )+abs( wi( i+1 ) ) ) THEN
626 sorted = .false.
627*
628 swap = wr( i )
629 wr( i ) = wr( i+1 )
630 wr( i+1 ) = swap
631*
632 swap = wi( i )
633 wi( i ) = wi( i+1 )
634 wi( i+1 ) = swap
635 END IF
636 40 CONTINUE
637 50 CONTINUE
638 60 CONTINUE
639 END IF
640*
641* ==== Shuffle shifts into pairs of real shifts
642* . and pairs of complex conjugate shifts
643* . assuming complex conjugate shifts are
644* . already adjacent to one another. (Yes,
645* . they are.) ====
646*
647 DO 70 i = kbot, ks + 2, -2
648 IF( wi( i ).NE.-wi( i-1 ) ) THEN
649*
650 swap = wr( i )
651 wr( i ) = wr( i-1 )
652 wr( i-1 ) = wr( i-2 )
653 wr( i-2 ) = swap
654*
655 swap = wi( i )
656 wi( i ) = wi( i-1 )
657 wi( i-1 ) = wi( i-2 )
658 wi( i-2 ) = swap
659 END IF
660 70 CONTINUE
661 END IF
662*
663* ==== If there are only two shifts and both are
664* . real, then use only one. ====
665*
666 IF( kbot-ks+1.EQ.2 ) THEN
667 IF( wi( kbot ).EQ.zero ) THEN
668 IF( abs( wr( kbot )-h( kbot, kbot ) ).LT.
669 $ abs( wr( kbot-1 )-h( kbot, kbot ) ) ) THEN
670 wr( kbot-1 ) = wr( kbot )
671 ELSE
672 wr( kbot ) = wr( kbot-1 )
673 END IF
674 END IF
675 END IF
676*
677* ==== Use up to NS of the the smallest magnitude
678* . shifts. If there aren't NS shifts available,
679* . then use them all, possibly dropping one to
680* . make the number of shifts even. ====
681*
682 ns = min( ns, kbot-ks+1 )
683 ns = ns - mod( ns, 2 )
684 ks = kbot - ns + 1
685*
686* ==== Small-bulge multi-shift QR sweep:
687* . split workspace under the subdiagonal into
688* . - a KDU-by-KDU work array U in the lower
689* . left-hand-corner,
690* . - a KDU-by-at-least-KDU-but-more-is-better
691* . (KDU-by-NHo) horizontal work array WH along
692* . the bottom edge,
693* . - and an at-least-KDU-but-more-is-better-by-KDU
694* . (NVE-by-KDU) vertical work WV arrow along
695* . the left-hand-edge. ====
696*
697 kdu = 2*ns
698 ku = n - kdu + 1
699 kwh = kdu + 1
700 nho = ( n-kdu+1-4 ) - ( kdu+1 ) + 1
701 kwv = kdu + 4
702 nve = n - kdu - kwv + 1
703*
704* ==== Small-bulge multi-shift QR sweep ====
705*
706 CALL dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,
707 $ wr( ks ), wi( ks ), h, ldh, iloz, ihiz, z,
708 $ ldz, work, 3, h( ku, 1 ), ldh, nve,
709 $ h( kwv, 1 ), ldh, nho, h( ku, kwh ), ldh )
710 END IF
711*
712* ==== Note progress (or the lack of it). ====
713*
714 IF( ld.GT.0 ) THEN
715 ndfl = 1
716 ELSE
717 ndfl = ndfl + 1
718 END IF
719*
720* ==== End of main loop ====
721 80 CONTINUE
722*
723* ==== Iteration limit exceeded. Set INFO to show where
724* . the problem occurred and exit. ====
725*
726 info = kbot
727 90 CONTINUE
728 END IF
729*
730* ==== Return the optimal value of LWORK. ====
731*
732 work( 1 ) = dble( lwkopt )
733*
734* ==== End of DLAQR4 ====
735*
dlaqr2
subroutine dlaqr2(wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sr, si, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate...
Definition dlaqr2.f:278

◆ dlaqr5()

subroutine dlaqr5 ( logical wantt,
logical wantz,
integer kacc22,
integer n,
integer ktop,
integer kbot,
integer nshfts,
double precision, dimension( * ) sr,
double precision, dimension( * ) si,
double precision, dimension( ldh, * ) h,
integer ldh,
integer iloz,
integer ihiz,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldu, * ) u,
integer ldu,
integer nv,
double precision, dimension( ldwv, * ) wv,
integer ldwv,
integer nh,
double precision, dimension( ldwh, * ) wh,
integer ldwh )

DLAQR5 performs a single small-bulge multi-shift QR sweep.

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

Purpose:
!>
!>    DLAQR5, called by DLAQR0, performs a
!>    single small-bulge multi-shift QR sweep.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>             WANTT = .true. if the quasi-triangular Schur factor
!>             is being computed.  WANTT is set to .false. otherwise.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>             WANTZ = .true. if the orthogonal Schur factor is being
!>             computed.  WANTZ is set to .false. otherwise.
!>
[in]KACC22
!>          KACC22 is INTEGER with value 0, 1, or 2.
!>             Specifies the computation mode of far-from-diagonal
!>             orthogonal updates.
!>        = 0: DLAQR5 does not accumulate reflections and does not
!>             use matrix-matrix multiply to update far-from-diagonal
!>             matrix entries.
!>        = 1: DLAQR5 accumulates reflections and uses matrix-matrix
!>             multiply to update the far-from-diagonal matrix entries.
!>        = 2: Same as KACC22 = 1. This option used to enable exploiting
!>             the 2-by-2 structure during matrix multiplications, but
!>             this is no longer supported.
!>
[in]N
!>          N is INTEGER
!>             N is the order of the Hessenberg matrix H upon which this
!>             subroutine operates.
!>
[in]KTOP
!>          KTOP is INTEGER
!>
[in]KBOT
!>          KBOT is INTEGER
!>             These are the first and last rows and columns of an
!>             isolated diagonal block upon which the QR sweep is to be
!>             applied. It is assumed without a check that
!>                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
!>             and
!>                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
!>
[in]NSHFTS
!>          NSHFTS is INTEGER
!>             NSHFTS gives the number of simultaneous shifts.  NSHFTS
!>             must be positive and even.
!>
[in,out]SR
!>          SR is DOUBLE PRECISION array, dimension (NSHFTS)
!>
[in,out]SI
!>          SI is DOUBLE PRECISION array, dimension (NSHFTS)
!>             SR contains the real parts and SI contains the imaginary
!>             parts of the NSHFTS shifts of origin that define the
!>             multi-shift QR sweep.  On output SR and SI may be
!>             reordered.
!>
[in,out]H
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>             On input H contains a Hessenberg matrix.  On output a
!>             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
!>             to the isolated diagonal block in rows and columns KTOP
!>             through KBOT.
!>
[in]LDH
!>          LDH is INTEGER
!>             LDH is the leading dimension of H just as declared in the
!>             calling procedure.  LDH >= MAX(1,N).
!>
[in]ILOZ
!>          ILOZ is INTEGER
!>
[in]IHIZ
!>          IHIZ is INTEGER
!>             Specify the rows of Z to which transformations must be
!>             applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ,IHIZ)
!>             If WANTZ = .TRUE., then the QR Sweep orthogonal
!>             similarity transformation is accumulated into
!>             Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right.
!>             If WANTZ = .FALSE., then Z is unreferenced.
!>
[in]LDZ
!>          LDZ is INTEGER
!>             LDA is the leading dimension of Z just as declared in
!>             the calling procedure. LDZ >= N.
!>
[out]V
!>          V is DOUBLE PRECISION array, dimension (LDV,NSHFTS/2)
!>
[in]LDV
!>          LDV is INTEGER
!>             LDV is the leading dimension of V as declared in the
!>             calling procedure.  LDV >= 3.
!>
[out]U
!>          U is DOUBLE PRECISION array, dimension (LDU,2*NSHFTS)
!>
[in]LDU
!>          LDU is INTEGER
!>             LDU is the leading dimension of U just as declared in the
!>             in the calling subroutine.  LDU >= 2*NSHFTS.
!>
[in]NV
!>          NV is INTEGER
!>             NV is the number of rows in WV agailable for workspace.
!>             NV >= 1.
!>
[out]WV
!>          WV is DOUBLE PRECISION array, dimension (LDWV,2*NSHFTS)
!>
[in]LDWV
!>          LDWV is INTEGER
!>             LDWV is the leading dimension of WV as declared in the
!>             in the calling subroutine.  LDWV >= NV.
!>
[in]NH
!>          NH is INTEGER
!>             NH is the number of columns in array WH available for
!>             workspace. NH >= 1.
!>
[out]WH
!>          WH is DOUBLE PRECISION array, dimension (LDWH,NH)
!>
[in]LDWH
!>          LDWH is INTEGER
!>             Leading dimension of WH just as declared in the
!>             calling procedure.  LDWH >= 2*NSHFTS.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Karen Braman and Ralph Byers, Department of Mathematics, University of Kansas, USA

Lars Karlsson, Daniel Kressner, and Bruno Lang

Thijs Steel, Department of Computer science, KU Leuven, Belgium

References:
K. Braman, R. Byers and R. Mathias, The Multi-Shift QR Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 Performance, SIAM Journal of Matrix Analysis, volume 23, pages 929–947, 2002.

Lars Karlsson, Daniel Kressner, and Bruno Lang, Optimally packed chains of bulges in multishift QR algorithms. ACM Trans. Math. Softw. 40, 2, Article 12 (February 2014).

Definition at line 262 of file dlaqr5.f.

265 IMPLICIT NONE
266*
267* -- LAPACK auxiliary routine --
268* -- LAPACK is a software package provided by Univ. of Tennessee, --
269* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
270*
271* .. Scalar Arguments ..
272 INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
273 $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
274 LOGICAL WANTT, WANTZ
275* ..
276* .. Array Arguments ..
277 DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
278 $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
279 $ Z( LDZ, * )
280* ..
281*
282* ================================================================
283* .. Parameters ..
284 DOUBLE PRECISION ZERO, ONE
285 parameter( zero = 0.0d0, one = 1.0d0 )
286* ..
287* .. Local Scalars ..
288 DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM,
289 $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
290 $ ULP
291 INTEGER I, I2, I4, INCOL, J, JBOT, JCOL, JLEN,
292 $ JROW, JTOP, K, K1, KDU, KMS, KRCOL,
293 $ M, M22, MBOT, MTOP, NBMPS, NDCOL,
294 $ NS, NU
295 LOGICAL ACCUM, BMP22
296* ..
297* .. External Functions ..
298 DOUBLE PRECISION DLAMCH
299 EXTERNAL dlamch
300* ..
301* .. Intrinsic Functions ..
302*
303 INTRINSIC abs, dble, max, min, mod
304* ..
305* .. Local Arrays ..
306 DOUBLE PRECISION VT( 3 )
307* ..
308* .. External Subroutines ..
309 EXTERNAL dgemm, dlabad, dlacpy, dlaqr1, dlarfg, dlaset,
310 $ dtrmm
311* ..
312* .. Executable Statements ..
313*
314* ==== If there are no shifts, then there is nothing to do. ====
315*
316 IF( nshfts.LT.2 )
317 $ RETURN
318*
319* ==== If the active block is empty or 1-by-1, then there
320* . is nothing to do. ====
321*
322 IF( ktop.GE.kbot )
323 $ RETURN
324*
325* ==== Shuffle shifts into pairs of real shifts and pairs
326* . of complex conjugate shifts assuming complex
327* . conjugate shifts are already adjacent to one
328* . another. ====
329*
330 DO 10 i = 1, nshfts - 2, 2
331 IF( si( i ).NE.-si( i+1 ) ) THEN
332*
333 swap = sr( i )
334 sr( i ) = sr( i+1 )
335 sr( i+1 ) = sr( i+2 )
336 sr( i+2 ) = swap
337*
338 swap = si( i )
339 si( i ) = si( i+1 )
340 si( i+1 ) = si( i+2 )
341 si( i+2 ) = swap
342 END IF
343 10 CONTINUE
344*
345* ==== NSHFTS is supposed to be even, but if it is odd,
346* . then simply reduce it by one. The shuffle above
347* . ensures that the dropped shift is real and that
348* . the remaining shifts are paired. ====
349*
350 ns = nshfts - mod( nshfts, 2 )
351*
352* ==== Machine constants for deflation ====
353*
354 safmin = dlamch( 'SAFE MINIMUM' )
355 safmax = one / safmin
356 CALL dlabad( safmin, safmax )
357 ulp = dlamch( 'PRECISION' )
358 smlnum = safmin*( dble( n ) / ulp )
359*
360* ==== Use accumulated reflections to update far-from-diagonal
361* . entries ? ====
362*
363 accum = ( kacc22.EQ.1 ) .OR. ( kacc22.EQ.2 )
364*
365* ==== clear trash ====
366*
367 IF( ktop+2.LE.kbot )
368 $ h( ktop+2, ktop ) = zero
369*
370* ==== NBMPS = number of 2-shift bulges in the chain ====
371*
372 nbmps = ns / 2
373*
374* ==== KDU = width of slab ====
375*
376 kdu = 4*nbmps
377*
378* ==== Create and chase chains of NBMPS bulges ====
379*
380 DO 180 incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps
381*
382* JTOP = Index from which updates from the right start.
383*
384 IF( accum ) THEN
385 jtop = max( ktop, incol )
386 ELSE IF( wantt ) THEN
387 jtop = 1
388 ELSE
389 jtop = ktop
390 END IF
391*
392 ndcol = incol + kdu
393 IF( accum )
394 $ CALL dlaset( 'ALL', kdu, kdu, zero, one, u, ldu )
395*
396* ==== Near-the-diagonal bulge chase. The following loop
397* . performs the near-the-diagonal part of a small bulge
398* . multi-shift QR sweep. Each 4*NBMPS column diagonal
399* . chunk extends from column INCOL to column NDCOL
400* . (including both column INCOL and column NDCOL). The
401* . following loop chases a 2*NBMPS+1 column long chain of
402* . NBMPS bulges 2*NBMPS columns to the right. (INCOL
403* . may be less than KTOP and and NDCOL may be greater than
404* . KBOT indicating phantom columns from which to chase
405* . bulges before they are actually introduced or to which
406* . to chase bulges beyond column KBOT.) ====
407*
408 DO 145 krcol = incol, min( incol+2*nbmps-1, kbot-2 )
409*
410* ==== Bulges number MTOP to MBOT are active double implicit
411* . shift bulges. There may or may not also be small
412* . 2-by-2 bulge, if there is room. The inactive bulges
413* . (if any) must wait until the active bulges have moved
414* . down the diagonal to make room. The phantom matrix
415* . paradigm described above helps keep track. ====
416*
417 mtop = max( 1, ( ktop-krcol ) / 2+1 )
418 mbot = min( nbmps, ( kbot-krcol-1 ) / 2 )
419 m22 = mbot + 1
420 bmp22 = ( mbot.LT.nbmps ) .AND. ( krcol+2*( m22-1 ) ).EQ.
421 $ ( kbot-2 )
422*
423* ==== Generate reflections to chase the chain right
424* . one column. (The minimum value of K is KTOP-1.) ====
425*
426 IF ( bmp22 ) THEN
427*
428* ==== Special case: 2-by-2 reflection at bottom treated
429* . separately ====
430*
431 k = krcol + 2*( m22-1 )
432 IF( k.EQ.ktop-1 ) THEN
433 CALL dlaqr1( 2, h( k+1, k+1 ), ldh, sr( 2*m22-1 ),
434 $ si( 2*m22-1 ), sr( 2*m22 ), si( 2*m22 ),
435 $ v( 1, m22 ) )
436 beta = v( 1, m22 )
437 CALL dlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) )
438 ELSE
439 beta = h( k+1, k )
440 v( 2, m22 ) = h( k+2, k )
441 CALL dlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) )
442 h( k+1, k ) = beta
443 h( k+2, k ) = zero
444 END IF
445
446*
447* ==== Perform update from right within
448* . computational window. ====
449*
450 DO 30 j = jtop, min( kbot, k+3 )
451 refsum = v( 1, m22 )*( h( j, k+1 )+v( 2, m22 )*
452 $ h( j, k+2 ) )
453 h( j, k+1 ) = h( j, k+1 ) - refsum
454 h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2, m22 )
455 30 CONTINUE
456*
457* ==== Perform update from left within
458* . computational window. ====
459*
460 IF( accum ) THEN
461 jbot = min( ndcol, kbot )
462 ELSE IF( wantt ) THEN
463 jbot = n
464 ELSE
465 jbot = kbot
466 END IF
467 DO 40 j = k+1, jbot
468 refsum = v( 1, m22 )*( h( k+1, j )+v( 2, m22 )*
469 $ h( k+2, j ) )
470 h( k+1, j ) = h( k+1, j ) - refsum
471 h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m22 )
472 40 CONTINUE
473*
474* ==== The following convergence test requires that
475* . the tradition small-compared-to-nearby-diagonals
476* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
477* . criteria both be satisfied. The latter improves
478* . accuracy in some examples. Falling back on an
479* . alternate convergence criterion when TST1 or TST2
480* . is zero (as done here) is traditional but probably
481* . unnecessary. ====
482*
483 IF( k.GE.ktop ) THEN
484 IF( h( k+1, k ).NE.zero ) THEN
485 tst1 = abs( h( k, k ) ) + abs( h( k+1, k+1 ) )
486 IF( tst1.EQ.zero ) THEN
487 IF( k.GE.ktop+1 )
488 $ tst1 = tst1 + abs( h( k, k-1 ) )
489 IF( k.GE.ktop+2 )
490 $ tst1 = tst1 + abs( h( k, k-2 ) )
491 IF( k.GE.ktop+3 )
492 $ tst1 = tst1 + abs( h( k, k-3 ) )
493 IF( k.LE.kbot-2 )
494 $ tst1 = tst1 + abs( h( k+2, k+1 ) )
495 IF( k.LE.kbot-3 )
496 $ tst1 = tst1 + abs( h( k+3, k+1 ) )
497 IF( k.LE.kbot-4 )
498 $ tst1 = tst1 + abs( h( k+4, k+1 ) )
499 END IF
500 IF( abs( h( k+1, k ) )
501 $ .LE.max( smlnum, ulp*tst1 ) ) THEN
502 h12 = max( abs( h( k+1, k ) ),
503 $ abs( h( k, k+1 ) ) )
504 h21 = min( abs( h( k+1, k ) ),
505 $ abs( h( k, k+1 ) ) )
506 h11 = max( abs( h( k+1, k+1 ) ),
507 $ abs( h( k, k )-h( k+1, k+1 ) ) )
508 h22 = min( abs( h( k+1, k+1 ) ),
509 $ abs( h( k, k )-h( k+1, k+1 ) ) )
510 scl = h11 + h12
511 tst2 = h22*( h11 / scl )
512*
513 IF( tst2.EQ.zero .OR. h21*( h12 / scl ).LE.
514 $ max( smlnum, ulp*tst2 ) ) THEN
515 h( k+1, k ) = zero
516 END IF
517 END IF
518 END IF
519 END IF
520*
521* ==== Accumulate orthogonal transformations. ====
522*
523 IF( accum ) THEN
524 kms = k - incol
525 DO 50 j = max( 1, ktop-incol ), kdu
526 refsum = v( 1, m22 )*( u( j, kms+1 )+
527 $ v( 2, m22 )*u( j, kms+2 ) )
528 u( j, kms+1 ) = u( j, kms+1 ) - refsum
529 u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2, m22 )
530 50 CONTINUE
531 ELSE IF( wantz ) THEN
532 DO 60 j = iloz, ihiz
533 refsum = v( 1, m22 )*( z( j, k+1 )+v( 2, m22 )*
534 $ z( j, k+2 ) )
535 z( j, k+1 ) = z( j, k+1 ) - refsum
536 z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2, m22 )
537 60 CONTINUE
538 END IF
539 END IF
540*
541* ==== Normal case: Chain of 3-by-3 reflections ====
542*
543 DO 80 m = mbot, mtop, -1
544 k = krcol + 2*( m-1 )
545 IF( k.EQ.ktop-1 ) THEN
546 CALL dlaqr1( 3, h( ktop, ktop ), ldh, sr( 2*m-1 ),
547 $ si( 2*m-1 ), sr( 2*m ), si( 2*m ),
548 $ v( 1, m ) )
549 alpha = v( 1, m )
550 CALL dlarfg( 3, alpha, v( 2, m ), 1, v( 1, m ) )
551 ELSE
552*
553* ==== Perform delayed transformation of row below
554* . Mth bulge. Exploit fact that first two elements
555* . of row are actually zero. ====
556*
557 refsum = v( 1, m )*v( 3, m )*h( k+3, k+2 )
558 h( k+3, k ) = -refsum
559 h( k+3, k+1 ) = -refsum*v( 2, m )
560 h( k+3, k+2 ) = h( k+3, k+2 ) - refsum*v( 3, m )
561*
562* ==== Calculate reflection to move
563* . Mth bulge one step. ====
564*
565 beta = h( k+1, k )
566 v( 2, m ) = h( k+2, k )
567 v( 3, m ) = h( k+3, k )
568 CALL dlarfg( 3, beta, v( 2, m ), 1, v( 1, m ) )
569*
570* ==== A Bulge may collapse because of vigilant
571* . deflation or destructive underflow. In the
572* . underflow case, try the two-small-subdiagonals
573* . trick to try to reinflate the bulge. ====
574*
575 IF( h( k+3, k ).NE.zero .OR. h( k+3, k+1 ).NE.
576 $ zero .OR. h( k+3, k+2 ).EQ.zero ) THEN
577*
578* ==== Typical case: not collapsed (yet). ====
579*
580 h( k+1, k ) = beta
581 h( k+2, k ) = zero
582 h( k+3, k ) = zero
583 ELSE
584*
585* ==== Atypical case: collapsed. Attempt to
586* . reintroduce ignoring H(K+1,K) and H(K+2,K).
587* . If the fill resulting from the new
588* . reflector is too large, then abandon it.
589* . Otherwise, use the new one. ====
590*
591 CALL dlaqr1( 3, h( k+1, k+1 ), ldh, sr( 2*m-1 ),
592 $ si( 2*m-1 ), sr( 2*m ), si( 2*m ),
593 $ vt )
594 alpha = vt( 1 )
595 CALL dlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) )
596 refsum = vt( 1 )*( h( k+1, k )+vt( 2 )*
597 $ h( k+2, k ) )
598*
599 IF( abs( h( k+2, k )-refsum*vt( 2 ) )+
600 $ abs( refsum*vt( 3 ) ).GT.ulp*
601 $ ( abs( h( k, k ) )+abs( h( k+1,
602 $ k+1 ) )+abs( h( k+2, k+2 ) ) ) ) THEN
603*
604* ==== Starting a new bulge here would
605* . create non-negligible fill. Use
606* . the old one with trepidation. ====
607*
608 h( k+1, k ) = beta
609 h( k+2, k ) = zero
610 h( k+3, k ) = zero
611 ELSE
612*
613* ==== Starting a new bulge here would
614* . create only negligible fill.
615* . Replace the old reflector with
616* . the new one. ====
617*
618 h( k+1, k ) = h( k+1, k ) - refsum
619 h( k+2, k ) = zero
620 h( k+3, k ) = zero
621 v( 1, m ) = vt( 1 )
622 v( 2, m ) = vt( 2 )
623 v( 3, m ) = vt( 3 )
624 END IF
625 END IF
626 END IF
627*
628* ==== Apply reflection from the right and
629* . the first column of update from the left.
630* . These updates are required for the vigilant
631* . deflation check. We still delay most of the
632* . updates from the left for efficiency. ====
633*
634 DO 70 j = jtop, min( kbot, k+3 )
635 refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*
636 $ h( j, k+2 )+v( 3, m )*h( j, k+3 ) )
637 h( j, k+1 ) = h( j, k+1 ) - refsum
638 h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2, m )
639 h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3, m )
640 70 CONTINUE
641*
642* ==== Perform update from left for subsequent
643* . column. ====
644*
645 refsum = v( 1, m )*( h( k+1, k+1 )+v( 2, m )*
646 $ h( k+2, k+1 )+v( 3, m )*h( k+3, k+1 ) )
647 h( k+1, k+1 ) = h( k+1, k+1 ) - refsum
648 h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m )
649 h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m )
650*
651* ==== The following convergence test requires that
652* . the tradition small-compared-to-nearby-diagonals
653* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
654* . criteria both be satisfied. The latter improves
655* . accuracy in some examples. Falling back on an
656* . alternate convergence criterion when TST1 or TST2
657* . is zero (as done here) is traditional but probably
658* . unnecessary. ====
659*
660 IF( k.LT.ktop)
661 $ cycle
662 IF( h( k+1, k ).NE.zero ) THEN
663 tst1 = abs( h( k, k ) ) + abs( h( k+1, k+1 ) )
664 IF( tst1.EQ.zero ) THEN
665 IF( k.GE.ktop+1 )
666 $ tst1 = tst1 + abs( h( k, k-1 ) )
667 IF( k.GE.ktop+2 )
668 $ tst1 = tst1 + abs( h( k, k-2 ) )
669 IF( k.GE.ktop+3 )
670 $ tst1 = tst1 + abs( h( k, k-3 ) )
671 IF( k.LE.kbot-2 )
672 $ tst1 = tst1 + abs( h( k+2, k+1 ) )
673 IF( k.LE.kbot-3 )
674 $ tst1 = tst1 + abs( h( k+3, k+1 ) )
675 IF( k.LE.kbot-4 )
676 $ tst1 = tst1 + abs( h( k+4, k+1 ) )
677 END IF
678 IF( abs( h( k+1, k ) ).LE.max( smlnum, ulp*tst1 ) )
679 $ THEN
680 h12 = max( abs( h( k+1, k ) ), abs( h( k, k+1 ) ) )
681 h21 = min( abs( h( k+1, k ) ), abs( h( k, k+1 ) ) )
682 h11 = max( abs( h( k+1, k+1 ) ),
683 $ abs( h( k, k )-h( k+1, k+1 ) ) )
684 h22 = min( abs( h( k+1, k+1 ) ),
685 $ abs( h( k, k )-h( k+1, k+1 ) ) )
686 scl = h11 + h12
687 tst2 = h22*( h11 / scl )
688*
689 IF( tst2.EQ.zero .OR. h21*( h12 / scl ).LE.
690 $ max( smlnum, ulp*tst2 ) ) THEN
691 h( k+1, k ) = zero
692 END IF
693 END IF
694 END IF
695 80 CONTINUE
696*
697* ==== Multiply H by reflections from the left ====
698*
699 IF( accum ) THEN
700 jbot = min( ndcol, kbot )
701 ELSE IF( wantt ) THEN
702 jbot = n
703 ELSE
704 jbot = kbot
705 END IF
706*
707 DO 100 m = mbot, mtop, -1
708 k = krcol + 2*( m-1 )
709 DO 90 j = max( ktop, krcol + 2*m ), jbot
710 refsum = v( 1, m )*( h( k+1, j )+v( 2, m )*
711 $ h( k+2, j )+v( 3, m )*h( k+3, j ) )
712 h( k+1, j ) = h( k+1, j ) - refsum
713 h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m )
714 h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m )
715 90 CONTINUE
716 100 CONTINUE
717*
718* ==== Accumulate orthogonal transformations. ====
719*
720 IF( accum ) THEN
721*
722* ==== Accumulate U. (If needed, update Z later
723* . with an efficient matrix-matrix
724* . multiply.) ====
725*
726 DO 120 m = mbot, mtop, -1
727 k = krcol + 2*( m-1 )
728 kms = k - incol
729 i2 = max( 1, ktop-incol )
730 i2 = max( i2, kms-(krcol-incol)+1 )
731 i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 )
732 DO 110 j = i2, i4
733 refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*
734 $ u( j, kms+2 )+v( 3, m )*u( j, kms+3 ) )
735 u( j, kms+1 ) = u( j, kms+1 ) - refsum
736 u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2, m )
737 u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3, m )
738 110 CONTINUE
739 120 CONTINUE
740 ELSE IF( wantz ) THEN
741*
742* ==== U is not accumulated, so update Z
743* . now by multiplying by reflections
744* . from the right. ====
745*
746 DO 140 m = mbot, mtop, -1
747 k = krcol + 2*( m-1 )
748 DO 130 j = iloz, ihiz
749 refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*
750 $ z( j, k+2 )+v( 3, m )*z( j, k+3 ) )
751 z( j, k+1 ) = z( j, k+1 ) - refsum
752 z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2, m )
753 z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3, m )
754 130 CONTINUE
755 140 CONTINUE
756 END IF
757*
758* ==== End of near-the-diagonal bulge chase. ====
759*
760 145 CONTINUE
761*
762* ==== Use U (if accumulated) to update far-from-diagonal
763* . entries in H. If required, use U to update Z as
764* . well. ====
765*
766 IF( accum ) THEN
767 IF( wantt ) THEN
768 jtop = 1
769 jbot = n
770 ELSE
771 jtop = ktop
772 jbot = kbot
773 END IF
774 k1 = max( 1, ktop-incol )
775 nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1
776*
777* ==== Horizontal Multiply ====
778*
779 DO 150 jcol = min( ndcol, kbot ) + 1, jbot, nh
780 jlen = min( nh, jbot-jcol+1 )
781 CALL dgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),
782 $ ldu, h( incol+k1, jcol ), ldh, zero, wh,
783 $ ldwh )
784 CALL dlacpy( 'ALL', nu, jlen, wh, ldwh,
785 $ h( incol+k1, jcol ), ldh )
786 150 CONTINUE
787*
788* ==== Vertical multiply ====
789*
790 DO 160 jrow = jtop, max( ktop, incol ) - 1, nv
791 jlen = min( nv, max( ktop, incol )-jrow )
792 CALL dgemm( 'N', 'N', jlen, nu, nu, one,
793 $ h( jrow, incol+k1 ), ldh, u( k1, k1 ),
794 $ ldu, zero, wv, ldwv )
795 CALL dlacpy( 'ALL', jlen, nu, wv, ldwv,
796 $ h( jrow, incol+k1 ), ldh )
797 160 CONTINUE
798*
799* ==== Z multiply (also vertical) ====
800*
801 IF( wantz ) THEN
802 DO 170 jrow = iloz, ihiz, nv
803 jlen = min( nv, ihiz-jrow+1 )
804 CALL dgemm( 'N', 'N', jlen, nu, nu, one,
805 $ z( jrow, incol+k1 ), ldz, u( k1, k1 ),
806 $ ldu, zero, wv, ldwv )
807 CALL dlacpy( 'ALL', jlen, nu, wv, ldwv,
808 $ z( jrow, incol+k1 ), ldz )
809 170 CONTINUE
810 END IF
811 END IF
812 180 CONTINUE
813*
814* ==== End of DLAQR5 ====
815*
dlaqr1
subroutine dlaqr1(n, h, ldh, sr1, si1, sr2, si2, v)
DLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and spe...
Definition dlaqr1.f:121

◆ dlaqsb()

subroutine dlaqsb ( character uplo,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) s,
double precision scond,
double precision amax,
character equed )

DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ.

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

Purpose:
!>
!> DLAQSB equilibrates a symmetric band matrix A using the scaling
!> factors in the vector S.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in,out]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
!>          On exit, if INFO = 0, the triangular factor U or L from the
!>          Cholesky factorization A = U**T*U or A = L*L**T of the band
!>          matrix A, in the same storage format as A.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is DOUBLE PRECISION
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix entry.
!>
[out]EQUED
!>          EQUED is CHARACTER*1
!>          Specifies whether or not equilibration was done.
!>          = 'N':  No equilibration.
!>          = 'Y':  Equilibration was done, i.e., A has been replaced by
!>                  diag(S) * A * diag(S).
!>
Internal Parameters:
!>  THRESH is a threshold value used to decide if scaling should be done
!>  based on the ratio of the scaling factors.  If SCOND < THRESH,
!>  scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if scaling should
!>  be done based on the absolute size of the largest matrix element.
!>  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file dlaqsb.f.

140*
141* -- LAPACK auxiliary 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 CHARACTER EQUED, UPLO
147 INTEGER KD, LDAB, N
148 DOUBLE PRECISION AMAX, SCOND
149* ..
150* .. Array Arguments ..
151 DOUBLE PRECISION AB( LDAB, * ), S( * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 DOUBLE PRECISION ONE, THRESH
158 parameter( one = 1.0d+0, thresh = 0.1d+0 )
159* ..
160* .. Local Scalars ..
161 INTEGER I, J
162 DOUBLE PRECISION CJ, LARGE, SMALL
163* ..
164* .. External Functions ..
165 LOGICAL LSAME
166 DOUBLE PRECISION DLAMCH
167 EXTERNAL lsame, dlamch
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC max, min
171* ..
172* .. Executable Statements ..
173*
174* Quick return if possible
175*
176 IF( n.LE.0 ) THEN
177 equed = 'N'
178 RETURN
179 END IF
180*
181* Initialize LARGE and SMALL.
182*
183 small = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
184 large = one / small
185*
186 IF( scond.GE.thresh .AND. amax.GE.small .AND. amax.LE.large ) THEN
187*
188* No equilibration
189*
190 equed = 'N'
191 ELSE
192*
193* Replace A by diag(S) * A * diag(S).
194*
195 IF( lsame( uplo, 'U' ) ) THEN
196*
197* Upper triangle of A is stored in band format.
198*
199 DO 20 j = 1, n
200 cj = s( j )
201 DO 10 i = max( 1, j-kd ), j
202 ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j )
203 10 CONTINUE
204 20 CONTINUE
205 ELSE
206*
207* Lower triangle of A is stored.
208*
209 DO 40 j = 1, n
210 cj = s( j )
211 DO 30 i = j, min( n, j+kd )
212 ab( 1+i-j, j ) = cj*s( i )*ab( 1+i-j, j )
213 30 CONTINUE
214 40 CONTINUE
215 END IF
216 equed = 'Y'
217 END IF
218*
219 RETURN
220*
221* End of DLAQSB
222*

◆ dlaqsp()

subroutine dlaqsp ( character uplo,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) s,
double precision scond,
double precision amax,
character equed )

DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ.

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

Purpose:
!>
!> DLAQSP equilibrates a symmetric matrix A using the scaling factors
!> in the vector S.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]AP
!>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          On entry, the upper or lower triangle of the symmetric matrix
!>          A, packed columnwise in a linear array.  The j-th column of A
!>          is stored in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
!>          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in
!>          the same storage format as A.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is DOUBLE PRECISION
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix entry.
!>
[out]EQUED
!>          EQUED is CHARACTER*1
!>          Specifies whether or not equilibration was done.
!>          = 'N':  No equilibration.
!>          = 'Y':  Equilibration was done, i.e., A has been replaced by
!>                  diag(S) * A * diag(S).
!>
Internal Parameters:
!>  THRESH is a threshold value used to decide if scaling should be done
!>  based on the ratio of the scaling factors.  If SCOND < THRESH,
!>  scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if scaling should
!>  be done based on the absolute size of the largest matrix element.
!>  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dlaqsp.f.

125*
126* -- LAPACK auxiliary routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER EQUED, UPLO
132 INTEGER N
133 DOUBLE PRECISION AMAX, SCOND
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION AP( * ), S( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, THRESH
143 parameter( one = 1.0d+0, thresh = 0.1d+0 )
144* ..
145* .. Local Scalars ..
146 INTEGER I, J, JC
147 DOUBLE PRECISION CJ, LARGE, SMALL
148* ..
149* .. External Functions ..
150 LOGICAL LSAME
151 DOUBLE PRECISION DLAMCH
152 EXTERNAL lsame, dlamch
153* ..
154* .. Executable Statements ..
155*
156* Quick return if possible
157*
158 IF( n.LE.0 ) THEN
159 equed = 'N'
160 RETURN
161 END IF
162*
163* Initialize LARGE and SMALL.
164*
165 small = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
166 large = one / small
167*
168 IF( scond.GE.thresh .AND. amax.GE.small .AND. amax.LE.large ) THEN
169*
170* No equilibration
171*
172 equed = 'N'
173 ELSE
174*
175* Replace A by diag(S) * A * diag(S).
176*
177 IF( lsame( uplo, 'U' ) ) THEN
178*
179* Upper triangle of A is stored.
180*
181 jc = 1
182 DO 20 j = 1, n
183 cj = s( j )
184 DO 10 i = 1, j
185 ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 )
186 10 CONTINUE
187 jc = jc + j
188 20 CONTINUE
189 ELSE
190*
191* Lower triangle of A is stored.
192*
193 jc = 1
194 DO 40 j = 1, n
195 cj = s( j )
196 DO 30 i = j, n
197 ap( jc+i-j ) = cj*s( i )*ap( jc+i-j )
198 30 CONTINUE
199 jc = jc + n - j + 1
200 40 CONTINUE
201 END IF
202 equed = 'Y'
203 END IF
204*
205 RETURN
206*
207* End of DLAQSP
208*
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ dlaqtr()

subroutine dlaqtr ( logical ltran,
logical lreal,
integer n,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( * ) b,
double precision w,
double precision scale,
double precision, dimension( * ) x,
double precision, dimension( * ) work,
integer info )

DLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system of special form, in real arithmetic.

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

Purpose:
!>
!> DLAQTR solves the real quasi-triangular system
!>
!>              op(T)*p = scale*c,               if LREAL = .TRUE.
!>
!> or the complex quasi-triangular systems
!>
!>            op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.
!>
!> in real arithmetic, where T is upper quasi-triangular.
!> If LREAL = .FALSE., then the first diagonal block of T must be
!> 1 by 1, B is the specially structured matrix
!>
!>                B = [ b(1) b(2) ... b(n) ]
!>                    [       w            ]
!>                    [           w        ]
!>                    [              .     ]
!>                    [                 w  ]
!>
!> op(A) = A or A**T, A**T denotes the transpose of
!> matrix A.
!>
!> On input, X = [ c ].  On output, X = [ p ].
!>               [ d ]                  [ q ]
!>
!> This subroutine is designed for the condition number estimation
!> in routine DTRSNA.
!>
Parameters
[in]LTRAN
!>          LTRAN is LOGICAL
!>          On entry, LTRAN specifies the option of conjugate transpose:
!>             = .FALSE.,    op(T+i*B) = T+i*B,
!>             = .TRUE.,     op(T+i*B) = (T+i*B)**T.
!>
[in]LREAL
!>          LREAL is LOGICAL
!>          On entry, LREAL specifies the input matrix structure:
!>             = .FALSE.,    the input is complex
!>             = .TRUE.,     the input is real
!>
[in]N
!>          N is INTEGER
!>          On entry, N specifies the order of T+i*B. N >= 0.
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,N)
!>          On entry, T contains a matrix in Schur canonical form.
!>          If LREAL = .FALSE., then the first diagonal block of T mu
!>          be 1 by 1.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the matrix T. LDT >= max(1,N).
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (N)
!>          On entry, B contains the elements to form the matrix
!>          B as described above.
!>          If LREAL = .TRUE., B is not referenced.
!>
[in]W
!>          W is DOUBLE PRECISION
!>          On entry, W is the diagonal element of the matrix B.
!>          If LREAL = .TRUE., W is not referenced.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          On exit, SCALE is the scale factor.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (2*N)
!>          On entry, X contains the right hand side of the system.
!>          On exit, X is overwritten by the solution.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          On exit, INFO is set to
!>             0: successful exit.
!>               1: the some diagonal 1 by 1 block has been perturbed by
!>                  a small number SMIN to keep nonsingularity.
!>               2: the some diagonal 2 by 2 block has been perturbed by
!>                  a small number in DLALN2 to keep nonsingularity.
!>          NOTE: In the interests of speed, this routine does not
!>                check the inputs for errors.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file dlaqtr.f.

165*
166* -- LAPACK auxiliary routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 LOGICAL LREAL, LTRAN
172 INTEGER INFO, LDT, N
173 DOUBLE PRECISION SCALE, W
174* ..
175* .. Array Arguments ..
176 DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * )
177* ..
178*
179* =====================================================================
180*
181* .. Parameters ..
182 DOUBLE PRECISION ZERO, ONE
183 parameter( zero = 0.0d+0, one = 1.0d+0 )
184* ..
185* .. Local Scalars ..
186 LOGICAL NOTRAN
187 INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
188 DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
189 $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
190* ..
191* .. Local Arrays ..
192 DOUBLE PRECISION D( 2, 2 ), V( 2, 2 )
193* ..
194* .. External Functions ..
195 INTEGER IDAMAX
196 DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
197 EXTERNAL idamax, dasum, ddot, dlamch, dlange
198* ..
199* .. External Subroutines ..
200 EXTERNAL daxpy, dladiv, dlaln2, dscal
201* ..
202* .. Intrinsic Functions ..
203 INTRINSIC abs, max
204* ..
205* .. Executable Statements ..
206*
207* Do not test the input parameters for errors
208*
209 notran = .NOT.ltran
210 info = 0
211*
212* Quick return if possible
213*
214 IF( n.EQ.0 )
215 $ RETURN
216*
217* Set constants to control overflow
218*
219 eps = dlamch( 'P' )
220 smlnum = dlamch( 'S' ) / eps
221 bignum = one / smlnum
222*
223 xnorm = dlange( 'M', n, n, t, ldt, d )
224 IF( .NOT.lreal )
225 $ xnorm = max( xnorm, abs( w ), dlange( 'M', n, 1, b, n, d ) )
226 smin = max( smlnum, eps*xnorm )
227*
228* Compute 1-norm of each column of strictly upper triangular
229* part of T to control overflow in triangular solver.
230*
231 work( 1 ) = zero
232 DO 10 j = 2, n
233 work( j ) = dasum( j-1, t( 1, j ), 1 )
234 10 CONTINUE
235*
236 IF( .NOT.lreal ) THEN
237 DO 20 i = 2, n
238 work( i ) = work( i ) + abs( b( i ) )
239 20 CONTINUE
240 END IF
241*
242 n2 = 2*n
243 n1 = n
244 IF( .NOT.lreal )
245 $ n1 = n2
246 k = idamax( n1, x, 1 )
247 xmax = abs( x( k ) )
248 scale = one
249*
250 IF( xmax.GT.bignum ) THEN
251 scale = bignum / xmax
252 CALL dscal( n1, scale, x, 1 )
253 xmax = bignum
254 END IF
255*
256 IF( lreal ) THEN
257*
258 IF( notran ) THEN
259*
260* Solve T*p = scale*c
261*
262 jnext = n
263 DO 30 j = n, 1, -1
264 IF( j.GT.jnext )
265 $ GO TO 30
266 j1 = j
267 j2 = j
268 jnext = j - 1
269 IF( j.GT.1 ) THEN
270 IF( t( j, j-1 ).NE.zero ) THEN
271 j1 = j - 1
272 jnext = j - 2
273 END IF
274 END IF
275*
276 IF( j1.EQ.j2 ) THEN
277*
278* Meet 1 by 1 diagonal block
279*
280* Scale to avoid overflow when computing
281* x(j) = b(j)/T(j,j)
282*
283 xj = abs( x( j1 ) )
284 tjj = abs( t( j1, j1 ) )
285 tmp = t( j1, j1 )
286 IF( tjj.LT.smin ) THEN
287 tmp = smin
288 tjj = smin
289 info = 1
290 END IF
291*
292 IF( xj.EQ.zero )
293 $ GO TO 30
294*
295 IF( tjj.LT.one ) THEN
296 IF( xj.GT.bignum*tjj ) THEN
297 rec = one / xj
298 CALL dscal( n, rec, x, 1 )
299 scale = scale*rec
300 xmax = xmax*rec
301 END IF
302 END IF
303 x( j1 ) = x( j1 ) / tmp
304 xj = abs( x( j1 ) )
305*
306* Scale x if necessary to avoid overflow when adding a
307* multiple of column j1 of T.
308*
309 IF( xj.GT.one ) THEN
310 rec = one / xj
311 IF( work( j1 ).GT.( bignum-xmax )*rec ) THEN
312 CALL dscal( n, rec, x, 1 )
313 scale = scale*rec
314 END IF
315 END IF
316 IF( j1.GT.1 ) THEN
317 CALL daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
318 k = idamax( j1-1, x, 1 )
319 xmax = abs( x( k ) )
320 END IF
321*
322 ELSE
323*
324* Meet 2 by 2 diagonal block
325*
326* Call 2 by 2 linear system solve, to take
327* care of possible overflow by scaling factor.
328*
329 d( 1, 1 ) = x( j1 )
330 d( 2, 1 ) = x( j2 )
331 CALL dlaln2( .false., 2, 1, smin, one, t( j1, j1 ),
332 $ ldt, one, one, d, 2, zero, zero, v, 2,
333 $ scaloc, xnorm, ierr )
334 IF( ierr.NE.0 )
335 $ info = 2
336*
337 IF( scaloc.NE.one ) THEN
338 CALL dscal( n, scaloc, x, 1 )
339 scale = scale*scaloc
340 END IF
341 x( j1 ) = v( 1, 1 )
342 x( j2 ) = v( 2, 1 )
343*
344* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
345* to avoid overflow in updating right-hand side.
346*
347 xj = max( abs( v( 1, 1 ) ), abs( v( 2, 1 ) ) )
348 IF( xj.GT.one ) THEN
349 rec = one / xj
350 IF( max( work( j1 ), work( j2 ) ).GT.
351 $ ( bignum-xmax )*rec ) THEN
352 CALL dscal( n, rec, x, 1 )
353 scale = scale*rec
354 END IF
355 END IF
356*
357* Update right-hand side
358*
359 IF( j1.GT.1 ) THEN
360 CALL daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
361 CALL daxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 )
362 k = idamax( j1-1, x, 1 )
363 xmax = abs( x( k ) )
364 END IF
365*
366 END IF
367*
368 30 CONTINUE
369*
370 ELSE
371*
372* Solve T**T*p = scale*c
373*
374 jnext = 1
375 DO 40 j = 1, n
376 IF( j.LT.jnext )
377 $ GO TO 40
378 j1 = j
379 j2 = j
380 jnext = j + 1
381 IF( j.LT.n ) THEN
382 IF( t( j+1, j ).NE.zero ) THEN
383 j2 = j + 1
384 jnext = j + 2
385 END IF
386 END IF
387*
388 IF( j1.EQ.j2 ) THEN
389*
390* 1 by 1 diagonal block
391*
392* Scale if necessary to avoid overflow in forming the
393* right-hand side element by inner product.
394*
395 xj = abs( x( j1 ) )
396 IF( xmax.GT.one ) THEN
397 rec = one / xmax
398 IF( work( j1 ).GT.( bignum-xj )*rec ) THEN
399 CALL dscal( n, rec, x, 1 )
400 scale = scale*rec
401 xmax = xmax*rec
402 END IF
403 END IF
404*
405 x( j1 ) = x( j1 ) - ddot( j1-1, t( 1, j1 ), 1, x, 1 )
406*
407 xj = abs( x( j1 ) )
408 tjj = abs( t( j1, j1 ) )
409 tmp = t( j1, j1 )
410 IF( tjj.LT.smin ) THEN
411 tmp = smin
412 tjj = smin
413 info = 1
414 END IF
415*
416 IF( tjj.LT.one ) THEN
417 IF( xj.GT.bignum*tjj ) THEN
418 rec = one / xj
419 CALL dscal( n, rec, x, 1 )
420 scale = scale*rec
421 xmax = xmax*rec
422 END IF
423 END IF
424 x( j1 ) = x( j1 ) / tmp
425 xmax = max( xmax, abs( x( j1 ) ) )
426*
427 ELSE
428*
429* 2 by 2 diagonal block
430*
431* Scale if necessary to avoid overflow in forming the
432* right-hand side elements by inner product.
433*
434 xj = max( abs( x( j1 ) ), abs( x( j2 ) ) )
435 IF( xmax.GT.one ) THEN
436 rec = one / xmax
437 IF( max( work( j2 ), work( j1 ) ).GT.( bignum-xj )*
438 $ rec ) THEN
439 CALL dscal( n, rec, x, 1 )
440 scale = scale*rec
441 xmax = xmax*rec
442 END IF
443 END IF
444*
445 d( 1, 1 ) = x( j1 ) - ddot( j1-1, t( 1, j1 ), 1, x,
446 $ 1 )
447 d( 2, 1 ) = x( j2 ) - ddot( j1-1, t( 1, j2 ), 1, x,
448 $ 1 )
449*
450 CALL dlaln2( .true., 2, 1, smin, one, t( j1, j1 ),
451 $ ldt, one, one, d, 2, zero, zero, v, 2,
452 $ scaloc, xnorm, ierr )
453 IF( ierr.NE.0 )
454 $ info = 2
455*
456 IF( scaloc.NE.one ) THEN
457 CALL dscal( n, scaloc, x, 1 )
458 scale = scale*scaloc
459 END IF
460 x( j1 ) = v( 1, 1 )
461 x( j2 ) = v( 2, 1 )
462 xmax = max( abs( x( j1 ) ), abs( x( j2 ) ), xmax )
463*
464 END IF
465 40 CONTINUE
466 END IF
467*
468 ELSE
469*
470 sminw = max( eps*abs( w ), smin )
471 IF( notran ) THEN
472*
473* Solve (T + iB)*(p+iq) = c+id
474*
475 jnext = n
476 DO 70 j = n, 1, -1
477 IF( j.GT.jnext )
478 $ GO TO 70
479 j1 = j
480 j2 = j
481 jnext = j - 1
482 IF( j.GT.1 ) THEN
483 IF( t( j, j-1 ).NE.zero ) THEN
484 j1 = j - 1
485 jnext = j - 2
486 END IF
487 END IF
488*
489 IF( j1.EQ.j2 ) THEN
490*
491* 1 by 1 diagonal block
492*
493* Scale if necessary to avoid overflow in division
494*
495 z = w
496 IF( j1.EQ.1 )
497 $ z = b( 1 )
498 xj = abs( x( j1 ) ) + abs( x( n+j1 ) )
499 tjj = abs( t( j1, j1 ) ) + abs( z )
500 tmp = t( j1, j1 )
501 IF( tjj.LT.sminw ) THEN
502 tmp = sminw
503 tjj = sminw
504 info = 1
505 END IF
506*
507 IF( xj.EQ.zero )
508 $ GO TO 70
509*
510 IF( tjj.LT.one ) THEN
511 IF( xj.GT.bignum*tjj ) THEN
512 rec = one / xj
513 CALL dscal( n2, rec, x, 1 )
514 scale = scale*rec
515 xmax = xmax*rec
516 END IF
517 END IF
518 CALL dladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si )
519 x( j1 ) = sr
520 x( n+j1 ) = si
521 xj = abs( x( j1 ) ) + abs( x( n+j1 ) )
522*
523* Scale x if necessary to avoid overflow when adding a
524* multiple of column j1 of T.
525*
526 IF( xj.GT.one ) THEN
527 rec = one / xj
528 IF( work( j1 ).GT.( bignum-xmax )*rec ) THEN
529 CALL dscal( n2, rec, x, 1 )
530 scale = scale*rec
531 END IF
532 END IF
533*
534 IF( j1.GT.1 ) THEN
535 CALL daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
536 CALL daxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,
537 $ x( n+1 ), 1 )
538*
539 x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 )
540 x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 )
541*
542 xmax = zero
543 DO 50 k = 1, j1 - 1
544 xmax = max( xmax, abs( x( k ) )+
545 $ abs( x( k+n ) ) )
546 50 CONTINUE
547 END IF
548*
549 ELSE
550*
551* Meet 2 by 2 diagonal block
552*
553 d( 1, 1 ) = x( j1 )
554 d( 2, 1 ) = x( j2 )
555 d( 1, 2 ) = x( n+j1 )
556 d( 2, 2 ) = x( n+j2 )
557 CALL dlaln2( .false., 2, 2, sminw, one, t( j1, j1 ),
558 $ ldt, one, one, d, 2, zero, -w, v, 2,
559 $ scaloc, xnorm, ierr )
560 IF( ierr.NE.0 )
561 $ info = 2
562*
563 IF( scaloc.NE.one ) THEN
564 CALL dscal( 2*n, scaloc, x, 1 )
565 scale = scaloc*scale
566 END IF
567 x( j1 ) = v( 1, 1 )
568 x( j2 ) = v( 2, 1 )
569 x( n+j1 ) = v( 1, 2 )
570 x( n+j2 ) = v( 2, 2 )
571*
572* Scale X(J1), .... to avoid overflow in
573* updating right hand side.
574*
575 xj = max( abs( v( 1, 1 ) )+abs( v( 1, 2 ) ),
576 $ abs( v( 2, 1 ) )+abs( v( 2, 2 ) ) )
577 IF( xj.GT.one ) THEN
578 rec = one / xj
579 IF( max( work( j1 ), work( j2 ) ).GT.
580 $ ( bignum-xmax )*rec ) THEN
581 CALL dscal( n2, rec, x, 1 )
582 scale = scale*rec
583 END IF
584 END IF
585*
586* Update the right-hand side.
587*
588 IF( j1.GT.1 ) THEN
589 CALL daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 )
590 CALL daxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 )
591*
592 CALL daxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,
593 $ x( n+1 ), 1 )
594 CALL daxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,
595 $ x( n+1 ), 1 )
596*
597 x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +
598 $ b( j2 )*x( n+j2 )
599 x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -
600 $ b( j2 )*x( j2 )
601*
602 xmax = zero
603 DO 60 k = 1, j1 - 1
604 xmax = max( abs( x( k ) )+abs( x( k+n ) ),
605 $ xmax )
606 60 CONTINUE
607 END IF
608*
609 END IF
610 70 CONTINUE
611*
612 ELSE
613*
614* Solve (T + iB)**T*(p+iq) = c+id
615*
616 jnext = 1
617 DO 80 j = 1, n
618 IF( j.LT.jnext )
619 $ GO TO 80
620 j1 = j
621 j2 = j
622 jnext = j + 1
623 IF( j.LT.n ) THEN
624 IF( t( j+1, j ).NE.zero ) THEN
625 j2 = j + 1
626 jnext = j + 2
627 END IF
628 END IF
629*
630 IF( j1.EQ.j2 ) THEN
631*
632* 1 by 1 diagonal block
633*
634* Scale if necessary to avoid overflow in forming the
635* right-hand side element by inner product.
636*
637 xj = abs( x( j1 ) ) + abs( x( j1+n ) )
638 IF( xmax.GT.one ) THEN
639 rec = one / xmax
640 IF( work( j1 ).GT.( bignum-xj )*rec ) THEN
641 CALL dscal( n2, rec, x, 1 )
642 scale = scale*rec
643 xmax = xmax*rec
644 END IF
645 END IF
646*
647 x( j1 ) = x( j1 ) - ddot( j1-1, t( 1, j1 ), 1, x, 1 )
648 x( n+j1 ) = x( n+j1 ) - ddot( j1-1, t( 1, j1 ), 1,
649 $ x( n+1 ), 1 )
650 IF( j1.GT.1 ) THEN
651 x( j1 ) = x( j1 ) - b( j1 )*x( n+1 )
652 x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 )
653 END IF
654 xj = abs( x( j1 ) ) + abs( x( j1+n ) )
655*
656 z = w
657 IF( j1.EQ.1 )
658 $ z = b( 1 )
659*
660* Scale if necessary to avoid overflow in
661* complex division
662*
663 tjj = abs( t( j1, j1 ) ) + abs( z )
664 tmp = t( j1, j1 )
665 IF( tjj.LT.sminw ) THEN
666 tmp = sminw
667 tjj = sminw
668 info = 1
669 END IF
670*
671 IF( tjj.LT.one ) THEN
672 IF( xj.GT.bignum*tjj ) THEN
673 rec = one / xj
674 CALL dscal( n2, rec, x, 1 )
675 scale = scale*rec
676 xmax = xmax*rec
677 END IF
678 END IF
679 CALL dladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si )
680 x( j1 ) = sr
681 x( j1+n ) = si
682 xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax )
683*
684 ELSE
685*
686* 2 by 2 diagonal block
687*
688* Scale if necessary to avoid overflow in forming the
689* right-hand side element by inner product.
690*
691 xj = max( abs( x( j1 ) )+abs( x( n+j1 ) ),
692 $ abs( x( j2 ) )+abs( x( n+j2 ) ) )
693 IF( xmax.GT.one ) THEN
694 rec = one / xmax
695 IF( max( work( j1 ), work( j2 ) ).GT.
696 $ ( bignum-xj ) / xmax ) THEN
697 CALL dscal( n2, rec, x, 1 )
698 scale = scale*rec
699 xmax = xmax*rec
700 END IF
701 END IF
702*
703 d( 1, 1 ) = x( j1 ) - ddot( j1-1, t( 1, j1 ), 1, x,
704 $ 1 )
705 d( 2, 1 ) = x( j2 ) - ddot( j1-1, t( 1, j2 ), 1, x,
706 $ 1 )
707 d( 1, 2 ) = x( n+j1 ) - ddot( j1-1, t( 1, j1 ), 1,
708 $ x( n+1 ), 1 )
709 d( 2, 2 ) = x( n+j2 ) - ddot( j1-1, t( 1, j2 ), 1,
710 $ x( n+1 ), 1 )
711 d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 )
712 d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 )
713 d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 )
714 d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 )
715*
716 CALL dlaln2( .true., 2, 2, sminw, one, t( j1, j1 ),
717 $ ldt, one, one, d, 2, zero, w, v, 2,
718 $ scaloc, xnorm, ierr )
719 IF( ierr.NE.0 )
720 $ info = 2
721*
722 IF( scaloc.NE.one ) THEN
723 CALL dscal( n2, scaloc, x, 1 )
724 scale = scaloc*scale
725 END IF
726 x( j1 ) = v( 1, 1 )
727 x( j2 ) = v( 2, 1 )
728 x( n+j1 ) = v( 1, 2 )
729 x( n+j2 ) = v( 2, 2 )
730 xmax = max( abs( x( j1 ) )+abs( x( n+j1 ) ),
731 $ abs( x( j2 ) )+abs( x( n+j2 ) ), xmax )
732*
733 END IF
734*
735 80 CONTINUE
736*
737 END IF
738*
739 END IF
740*
741 RETURN
742*
743* End of DLAQTR
744*
dlaln2
subroutine dlaln2(ltrans, na, nw, smin, ca, a, lda, d1, d2, b, ldb, wr, wi, x, ldx, scale, xnorm, info)
DLALN2 solves a 1-by-1 or 2-by-2 linear system of equations of the specified form.
Definition dlaln2.f:218

◆ dlar1v()

subroutine dlar1v ( integer n,
integer b1,
integer bn,
double precision lambda,
double precision, dimension( * ) d,
double precision, dimension( * ) l,
double precision, dimension( * ) ld,
double precision, dimension( * ) lld,
double precision pivmin,
double precision gaptol,
double precision, dimension( * ) z,
logical wantnc,
integer negcnt,
double precision ztz,
double precision mingma,
integer r,
integer, dimension( * ) isuppz,
double precision nrminv,
double precision resid,
double precision rqcorr,
double precision, dimension( * ) work )

DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI.

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

Purpose:
!>
!> DLAR1V computes the (scaled) r-th column of the inverse of
!> the sumbmatrix in rows B1 through BN of the tridiagonal matrix
!> L D L**T - sigma I. When sigma is close to an eigenvalue, the
!> computed vector is an accurate eigenvector. Usually, r corresponds
!> to the index where the eigenvector is largest in magnitude.
!> The following steps accomplish this computation :
!> (a) Stationary qd transform,  L D L**T - sigma I = L(+) D(+) L(+)**T,
!> (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T,
!> (c) Computation of the diagonal elements of the inverse of
!>     L D L**T - sigma I by combining the above transforms, and choosing
!>     r as the index where the diagonal of the inverse is (one of the)
!>     largest in magnitude.
!> (d) Computation of the (scaled) r-th column of the inverse using the
!>     twisted factorization obtained by combining the top part of the
!>     the stationary and the bottom part of the progressive transform.
!>
Parameters
[in]N
!>          N is INTEGER
!>           The order of the matrix L D L**T.
!>
[in]B1
!>          B1 is INTEGER
!>           First index of the submatrix of L D L**T.
!>
[in]BN
!>          BN is INTEGER
!>           Last index of the submatrix of L D L**T.
!>
[in]LAMBDA
!>          LAMBDA is DOUBLE PRECISION
!>           The shift. In order to compute an accurate eigenvector,
!>           LAMBDA should be a good approximation to an eigenvalue
!>           of L D L**T.
!>
[in]L
!>          L is DOUBLE PRECISION array, dimension (N-1)
!>           The (n-1) subdiagonal elements of the unit bidiagonal matrix
!>           L, in elements 1 to N-1.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>           The n diagonal elements of the diagonal matrix D.
!>
[in]LD
!>          LD is DOUBLE PRECISION array, dimension (N-1)
!>           The n-1 elements L(i)*D(i).
!>
[in]LLD
!>          LLD is DOUBLE PRECISION array, dimension (N-1)
!>           The n-1 elements L(i)*L(i)*D(i).
!>
[in]PIVMIN
!>          PIVMIN is DOUBLE PRECISION
!>           The minimum pivot in the Sturm sequence.
!>
[in]GAPTOL
!>          GAPTOL is DOUBLE PRECISION
!>           Tolerance that indicates when eigenvector entries are negligible
!>           w.r.t. their contribution to the residual.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array, dimension (N)
!>           On input, all entries of Z must be set to 0.
!>           On output, Z contains the (scaled) r-th column of the
!>           inverse. The scaling is such that Z(R) equals 1.
!>
[in]WANTNC
!>          WANTNC is LOGICAL
!>           Specifies whether NEGCNT has to be computed.
!>
[out]NEGCNT
!>          NEGCNT is INTEGER
!>           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
!>           in the  matrix factorization L D L**T, and NEGCNT = -1 otherwise.
!>
[out]ZTZ
!>          ZTZ is DOUBLE PRECISION
!>           The square of the 2-norm of Z.
!>
[out]MINGMA
!>          MINGMA is DOUBLE PRECISION
!>           The reciprocal of the largest (in magnitude) diagonal
!>           element of the inverse of L D L**T - sigma I.
!>
[in,out]R
!>          R is INTEGER
!>           The twist index for the twisted factorization used to
!>           compute Z.
!>           On input, 0 <= R <= N. If R is input as 0, R is set to
!>           the index where (L D L**T - sigma I)^{-1} is largest
!>           in magnitude. If 1 <= R <= N, R is unchanged.
!>           On output, R contains the twist index used to compute Z.
!>           Ideally, R designates the position of the maximum entry in the
!>           eigenvector.
!>
[out]ISUPPZ
!>          ISUPPZ is INTEGER array, dimension (2)
!>           The support of the vector in Z, i.e., the vector Z is
!>           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
!>
[out]NRMINV
!>          NRMINV is DOUBLE PRECISION
!>           NRMINV = 1/SQRT( ZTZ )
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>           The residual of the FP vector.
!>           RESID = ABS( MINGMA )/SQRT( ZTZ )
!>
[out]RQCORR
!>          RQCORR is DOUBLE PRECISION
!>           The Rayleigh Quotient correction to LAMBDA.
!>           RQCORR = MINGMA*TMP
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (4*N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 227 of file dlar1v.f.

230*
231* -- LAPACK auxiliary routine --
232* -- LAPACK is a software package provided by Univ. of Tennessee, --
233* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
234*
235* .. Scalar Arguments ..
236 LOGICAL WANTNC
237 INTEGER B1, BN, N, NEGCNT, R
238 DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
239 $ RQCORR, ZTZ
240* ..
241* .. Array Arguments ..
242 INTEGER ISUPPZ( * )
243 DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
244 $ WORK( * )
245 DOUBLE PRECISION Z( * )
246* ..
247*
248* =====================================================================
249*
250* .. Parameters ..
251 DOUBLE PRECISION ZERO, ONE
252 parameter( zero = 0.0d0, one = 1.0d0 )
253
254* ..
255* .. Local Scalars ..
256 LOGICAL SAWNAN1, SAWNAN2
257 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
258 $ R2
259 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
260* ..
261* .. External Functions ..
262 LOGICAL DISNAN
263 DOUBLE PRECISION DLAMCH
264 EXTERNAL disnan, dlamch
265* ..
266* .. Intrinsic Functions ..
267 INTRINSIC abs
268* ..
269* .. Executable Statements ..
270*
271 eps = dlamch( 'Precision' )
272
273
274 IF( r.EQ.0 ) THEN
275 r1 = b1
276 r2 = bn
277 ELSE
278 r1 = r
279 r2 = r
280 END IF
281
282* Storage for LPLUS
283 indlpl = 0
284* Storage for UMINUS
285 indumn = n
286 inds = 2*n + 1
287 indp = 3*n + 1
288
289 IF( b1.EQ.1 ) THEN
290 work( inds ) = zero
291 ELSE
292 work( inds+b1-1 ) = lld( b1-1 )
293 END IF
294
295*
296* Compute the stationary transform (using the differential form)
297* until the index R2.
298*
299 sawnan1 = .false.
300 neg1 = 0
301 s = work( inds+b1-1 ) - lambda
302 DO 50 i = b1, r1 - 1
303 dplus = d( i ) + s
304 work( indlpl+i ) = ld( i ) / dplus
305 IF(dplus.LT.zero) neg1 = neg1 + 1
306 work( inds+i ) = s*work( indlpl+i )*l( i )
307 s = work( inds+i ) - lambda
308 50 CONTINUE
309 sawnan1 = disnan( s )
310 IF( sawnan1 ) GOTO 60
311 DO 51 i = r1, r2 - 1
312 dplus = d( i ) + s
313 work( indlpl+i ) = ld( i ) / dplus
314 work( inds+i ) = s*work( indlpl+i )*l( i )
315 s = work( inds+i ) - lambda
316 51 CONTINUE
317 sawnan1 = disnan( s )
318*
319 60 CONTINUE
320 IF( sawnan1 ) THEN
321* Runs a slower version of the above loop if a NaN is detected
322 neg1 = 0
323 s = work( inds+b1-1 ) - lambda
324 DO 70 i = b1, r1 - 1
325 dplus = d( i ) + s
326 IF(abs(dplus).LT.pivmin) dplus = -pivmin
327 work( indlpl+i ) = ld( i ) / dplus
328 IF(dplus.LT.zero) neg1 = neg1 + 1
329 work( inds+i ) = s*work( indlpl+i )*l( i )
330 IF( work( indlpl+i ).EQ.zero )
331 $ work( inds+i ) = lld( i )
332 s = work( inds+i ) - lambda
333 70 CONTINUE
334 DO 71 i = r1, r2 - 1
335 dplus = d( i ) + s
336 IF(abs(dplus).LT.pivmin) dplus = -pivmin
337 work( indlpl+i ) = ld( i ) / dplus
338 work( inds+i ) = s*work( indlpl+i )*l( i )
339 IF( work( indlpl+i ).EQ.zero )
340 $ work( inds+i ) = lld( i )
341 s = work( inds+i ) - lambda
342 71 CONTINUE
343 END IF
344*
345* Compute the progressive transform (using the differential form)
346* until the index R1
347*
348 sawnan2 = .false.
349 neg2 = 0
350 work( indp+bn-1 ) = d( bn ) - lambda
351 DO 80 i = bn - 1, r1, -1
352 dminus = lld( i ) + work( indp+i )
353 tmp = d( i ) / dminus
354 IF(dminus.LT.zero) neg2 = neg2 + 1
355 work( indumn+i ) = l( i )*tmp
356 work( indp+i-1 ) = work( indp+i )*tmp - lambda
357 80 CONTINUE
358 tmp = work( indp+r1-1 )
359 sawnan2 = disnan( tmp )
360
361 IF( sawnan2 ) THEN
362* Runs a slower version of the above loop if a NaN is detected
363 neg2 = 0
364 DO 100 i = bn-1, r1, -1
365 dminus = lld( i ) + work( indp+i )
366 IF(abs(dminus).LT.pivmin) dminus = -pivmin
367 tmp = d( i ) / dminus
368 IF(dminus.LT.zero) neg2 = neg2 + 1
369 work( indumn+i ) = l( i )*tmp
370 work( indp+i-1 ) = work( indp+i )*tmp - lambda
371 IF( tmp.EQ.zero )
372 $ work( indp+i-1 ) = d( i ) - lambda
373 100 CONTINUE
374 END IF
375*
376* Find the index (from R1 to R2) of the largest (in magnitude)
377* diagonal element of the inverse
378*
379 mingma = work( inds+r1-1 ) + work( indp+r1-1 )
380 IF( mingma.LT.zero ) neg1 = neg1 + 1
381 IF( wantnc ) THEN
382 negcnt = neg1 + neg2
383 ELSE
384 negcnt = -1
385 ENDIF
386 IF( abs(mingma).EQ.zero )
387 $ mingma = eps*work( inds+r1-1 )
388 r = r1
389 DO 110 i = r1, r2 - 1
390 tmp = work( inds+i ) + work( indp+i )
391 IF( tmp.EQ.zero )
392 $ tmp = eps*work( inds+i )
393 IF( abs( tmp ).LE.abs( mingma ) ) THEN
394 mingma = tmp
395 r = i + 1
396 END IF
397 110 CONTINUE
398*
399* Compute the FP vector: solve N^T v = e_r
400*
401 isuppz( 1 ) = b1
402 isuppz( 2 ) = bn
403 z( r ) = one
404 ztz = one
405*
406* Compute the FP vector upwards from R
407*
408 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 ) THEN
409 DO 210 i = r-1, b1, -1
410 z( i ) = -( work( indlpl+i )*z( i+1 ) )
411 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
412 $ THEN
413 z( i ) = zero
414 isuppz( 1 ) = i + 1
415 GOTO 220
416 ENDIF
417 ztz = ztz + z( i )*z( i )
418 210 CONTINUE
419 220 CONTINUE
420 ELSE
421* Run slower loop if NaN occurred.
422 DO 230 i = r - 1, b1, -1
423 IF( z( i+1 ).EQ.zero ) THEN
424 z( i ) = -( ld( i+1 ) / ld( i ) )*z( i+2 )
425 ELSE
426 z( i ) = -( work( indlpl+i )*z( i+1 ) )
427 END IF
428 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
429 $ THEN
430 z( i ) = zero
431 isuppz( 1 ) = i + 1
432 GO TO 240
433 END IF
434 ztz = ztz + z( i )*z( i )
435 230 CONTINUE
436 240 CONTINUE
437 ENDIF
438
439* Compute the FP vector downwards from R in blocks of size BLKSIZ
440 IF( .NOT.sawnan1 .AND. .NOT.sawnan2 ) THEN
441 DO 250 i = r, bn-1
442 z( i+1 ) = -( work( indumn+i )*z( i ) )
443 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
444 $ THEN
445 z( i+1 ) = zero
446 isuppz( 2 ) = i
447 GO TO 260
448 END IF
449 ztz = ztz + z( i+1 )*z( i+1 )
450 250 CONTINUE
451 260 CONTINUE
452 ELSE
453* Run slower loop if NaN occurred.
454 DO 270 i = r, bn - 1
455 IF( z( i ).EQ.zero ) THEN
456 z( i+1 ) = -( ld( i-1 ) / ld( i ) )*z( i-1 )
457 ELSE
458 z( i+1 ) = -( work( indumn+i )*z( i ) )
459 END IF
460 IF( (abs(z(i))+abs(z(i+1)))* abs(ld(i)).LT.gaptol )
461 $ THEN
462 z( i+1 ) = zero
463 isuppz( 2 ) = i
464 GO TO 280
465 END IF
466 ztz = ztz + z( i+1 )*z( i+1 )
467 270 CONTINUE
468 280 CONTINUE
469 END IF
470*
471* Compute quantities for convergence test
472*
473 tmp = one / ztz
474 nrminv = sqrt( tmp )
475 resid = abs( mingma )*nrminv
476 rqcorr = mingma*tmp
477*
478*
479 RETURN
480*
481* End of DLAR1V
482*

◆ dlar2v()

subroutine dlar2v ( integer n,
double precision, dimension( * ) x,
double precision, dimension( * ) y,
double precision, dimension( * ) z,
integer incx,
double precision, dimension( * ) c,
double precision, dimension( * ) s,
integer incc )

DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.

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

Purpose:
!>
!> DLAR2V applies a vector of real plane rotations from both sides to
!> a sequence of 2-by-2 real symmetric matrices, defined by the elements
!> of the vectors x, y and z. For i = 1,2,...,n
!>
!>    ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
!>    ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of plane rotations to be applied.
!>
[in,out]X
!>          X is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector x.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector y.
!>
[in,out]Z
!>          Z is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector z.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X, Y and Z. INCX > 0.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The sines of the plane rotations.
!>
[in]INCC
!>          INCC is INTEGER
!>          The increment between elements of C and S. INCC > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 109 of file dlar2v.f.

110*
111* -- LAPACK auxiliary routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 INTEGER INCC, INCX, N
117* ..
118* .. Array Arguments ..
119 DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * )
120* ..
121*
122* =====================================================================
123*
124* .. Local Scalars ..
125 INTEGER I, IC, IX
126 DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
127* ..
128* .. Executable Statements ..
129*
130 ix = 1
131 ic = 1
132 DO 10 i = 1, n
133 xi = x( ix )
134 yi = y( ix )
135 zi = z( ix )
136 ci = c( ic )
137 si = s( ic )
138 t1 = si*zi
139 t2 = ci*zi
140 t3 = t2 - si*xi
141 t4 = t2 + si*yi
142 t5 = ci*xi + t1
143 t6 = ci*yi - t1
144 x( ix ) = ci*t5 + si*t4
145 y( ix ) = ci*t6 - si*t3
146 z( ix ) = ci*t4 - si*t5
147 ix = ix + incx
148 ic = ic + incc
149 10 CONTINUE
150*
151* End of DLAR2V
152*
153 RETURN

◆ dlarf()

subroutine dlarf ( character side,
integer m,
integer n,
double precision, dimension( * ) v,
integer incv,
double precision tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work )

DLARF applies an elementary reflector to a general rectangular matrix.

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

Purpose:
!>
!> DLARF applies a real elementary reflector H to a real m by n matrix
!> C, from either the left or the right. H is represented in the form
!>
!>       H = I - tau * v * v**T
!>
!> where tau is a real scalar and v is a real vector.
!>
!> If tau = 0, then H is taken to be the unit matrix.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': form  H * C
!>          = 'R': form  C * H
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
!>                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
!>          The vector v in the representation of H. V is not used if
!>          TAU = 0.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between elements of v. INCV <> 0.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!>          or C * H if SIDE = 'R'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                         (N) if SIDE = 'L'
!>                      or (M) if SIDE = 'R'
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dlarf.f.

124*
125* -- LAPACK auxiliary routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER SIDE
131 INTEGER INCV, LDC, M, N
132 DOUBLE PRECISION TAU
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 DOUBLE PRECISION ONE, ZERO
142 parameter( one = 1.0d+0, zero = 0.0d+0 )
143* ..
144* .. Local Scalars ..
145 LOGICAL APPLYLEFT
146 INTEGER I, LASTV, LASTC
147* ..
148* .. External Subroutines ..
149 EXTERNAL dgemv, dger
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 INTEGER ILADLR, ILADLC
154 EXTERNAL lsame, iladlr, iladlc
155* ..
156* .. Executable Statements ..
157*
158 applyleft = lsame( side, 'L' )
159 lastv = 0
160 lastc = 0
161 IF( tau.NE.zero ) THEN
162! Set up variables for scanning V. LASTV begins pointing to the end
163! of V.
164 IF( applyleft ) THEN
165 lastv = m
166 ELSE
167 lastv = n
168 END IF
169 IF( incv.GT.0 ) THEN
170 i = 1 + (lastv-1) * incv
171 ELSE
172 i = 1
173 END IF
174! Look for the last non-zero row in V.
175 DO WHILE( lastv.GT.0 .AND. v( i ).EQ.zero )
176 lastv = lastv - 1
177 i = i - incv
178 END DO
179 IF( applyleft ) THEN
180! Scan for the last non-zero column in C(1:lastv,:).
181 lastc = iladlc(lastv, n, c, ldc)
182 ELSE
183! Scan for the last non-zero row in C(:,1:lastv).
184 lastc = iladlr(m, lastv, c, ldc)
185 END IF
186 END IF
187! Note that lastc.eq.0 renders the BLAS operations null; no special
188! case is needed at this level.
189 IF( applyleft ) THEN
190*
191* Form H * C
192*
193 IF( lastv.GT.0 ) THEN
194*
195* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
196*
197 CALL dgemv( 'Transpose', lastv, lastc, one, c, ldc, v, incv,
198 $ zero, work, 1 )
199*
200* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
201*
202 CALL dger( lastv, lastc, -tau, v, incv, work, 1, c, ldc )
203 END IF
204 ELSE
205*
206* Form C * H
207*
208 IF( lastv.GT.0 ) THEN
209*
210* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
211*
212 CALL dgemv( 'No transpose', lastc, lastv, one, c, ldc,
213 $ v, incv, zero, work, 1 )
214*
215* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
216*
217 CALL dger( lastc, lastv, -tau, work, 1, v, incv, c, ldc )
218 END IF
219 END IF
220 RETURN
221*
222* End of DLARF
223*
iladlc
integer function iladlc(m, n, a, lda)
ILADLC scans a matrix for its last non-zero column.
Definition iladlc.f:78
iladlr
integer function iladlr(m, n, a, lda)
ILADLR scans a matrix for its last non-zero row.
Definition iladlr.f:78
dger
subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
DGER
Definition dger.f:130

◆ dlarfb()

subroutine dlarfb ( character side,
character trans,
character direct,
character storev,
integer m,
integer n,
integer k,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( ldwork, * ) work,
integer ldwork )

DLARFB applies a block reflector or its transpose to a general rectangular matrix.

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

Purpose:
!>
!> DLARFB applies a real block reflector H or its transpose H**T to a
!> real m by n matrix C, from either the left or the right.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply H or H**T from the Left
!>          = 'R': apply H or H**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply H (No transpose)
!>          = 'T': apply H**T (Transpose)
!>
[in]DIRECT
!>          DIRECT is CHARACTER*1
!>          Indicates how H is formed from a product of elementary
!>          reflectors
!>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
!>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!>
[in]STOREV
!>          STOREV is CHARACTER*1
!>          Indicates how the vectors which define the elementary
!>          reflectors are stored:
!>          = 'C': Columnwise
!>          = 'R': Rowwise
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C.
!>
[in]K
!>          K is INTEGER
!>          The order of the matrix T (= the number of elementary
!>          reflectors whose product defines the block reflector).
!>          If SIDE = 'L', M >= K >= 0;
!>          if SIDE = 'R', N >= K >= 0.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                                (LDV,K) if STOREV = 'C'
!>                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
!>                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
!>          The matrix V. See Further Details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
!>          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
!>          if STOREV = 'R', LDV >= K.
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The triangular k by k matrix T in the representation of the
!>          block reflector.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= K.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.
!>          If SIDE = 'L', LDWORK >= max(1,N);
!>          if SIDE = 'R', LDWORK >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The shape of the matrix V and the storage of the vectors which define
!>  the H(i) is best illustrated by the following example with n = 5 and
!>  k = 3. The elements equal to 1 are not stored; the corresponding
!>  array elements are modified but restored on exit. The rest of the
!>  array is not used.
!>
!>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
!>
!>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
!>                   ( v1  1    )                     (     1 v2 v2 v2 )
!>                   ( v1 v2  1 )                     (        1 v3 v3 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!>
!>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
!>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
!>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
!>                   (     1 v3 )
!>                   (        1 )
!>

Definition at line 195 of file dlarfb.f.

197*
198* -- LAPACK auxiliary routine --
199* -- LAPACK is a software package provided by Univ. of Tennessee, --
200* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
201*
202* .. Scalar Arguments ..
203 CHARACTER DIRECT, SIDE, STOREV, TRANS
204 INTEGER K, LDC, LDT, LDV, LDWORK, M, N
205* ..
206* .. Array Arguments ..
207 DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
208 $ WORK( LDWORK, * )
209* ..
210*
211* =====================================================================
212*
213* .. Parameters ..
214 DOUBLE PRECISION ONE
215 parameter( one = 1.0d+0 )
216* ..
217* .. Local Scalars ..
218 CHARACTER TRANST
219 INTEGER I, J
220* ..
221* .. External Functions ..
222 LOGICAL LSAME
223 EXTERNAL lsame
224* ..
225* .. External Subroutines ..
226 EXTERNAL dcopy, dgemm, dtrmm
227* ..
228* .. Executable Statements ..
229*
230* Quick return if possible
231*
232 IF( m.LE.0 .OR. n.LE.0 )
233 $ RETURN
234*
235 IF( lsame( trans, 'N' ) ) THEN
236 transt = 'T'
237 ELSE
238 transt = 'N'
239 END IF
240*
241 IF( lsame( storev, 'C' ) ) THEN
242*
243 IF( lsame( direct, 'F' ) ) THEN
244*
245* Let V = ( V1 ) (first K rows)
246* ( V2 )
247* where V1 is unit lower triangular.
248*
249 IF( lsame( side, 'L' ) ) THEN
250*
251* Form H * C or H**T * C where C = ( C1 )
252* ( C2 )
253*
254* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
255*
256* W := C1**T
257*
258 DO 10 j = 1, k
259 CALL dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
260 10 CONTINUE
261*
262* W := W * V1
263*
264 CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit', n,
265 $ k, one, v, ldv, work, ldwork )
266 IF( m.GT.k ) THEN
267*
268* W := W + C2**T * V2
269*
270 CALL dgemm( 'Transpose', 'No transpose', n, k, m-k,
271 $ one, c( k+1, 1 ), ldc, v( k+1, 1 ), ldv,
272 $ one, work, ldwork )
273 END IF
274*
275* W := W * T**T or W * T
276*
277 CALL dtrmm( 'Right', 'Upper', transt, 'Non-unit', n, k,
278 $ one, t, ldt, work, ldwork )
279*
280* C := C - V * W**T
281*
282 IF( m.GT.k ) THEN
283*
284* C2 := C2 - V2 * W**T
285*
286 CALL dgemm( 'No transpose', 'Transpose', m-k, n, k,
287 $ -one, v( k+1, 1 ), ldv, work, ldwork, one,
288 $ c( k+1, 1 ), ldc )
289 END IF
290*
291* W := W * V1**T
292*
293 CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit', n, k,
294 $ one, v, ldv, work, ldwork )
295*
296* C1 := C1 - W**T
297*
298 DO 30 j = 1, k
299 DO 20 i = 1, n
300 c( j, i ) = c( j, i ) - work( i, j )
301 20 CONTINUE
302 30 CONTINUE
303*
304 ELSE IF( lsame( side, 'R' ) ) THEN
305*
306* Form C * H or C * H**T where C = ( C1 C2 )
307*
308* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
309*
310* W := C1
311*
312 DO 40 j = 1, k
313 CALL dcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
314 40 CONTINUE
315*
316* W := W * V1
317*
318 CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit', m,
319 $ k, one, v, ldv, work, ldwork )
320 IF( n.GT.k ) THEN
321*
322* W := W + C2 * V2
323*
324 CALL dgemm( 'No transpose', 'No transpose', m, k, n-k,
325 $ one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv,
326 $ one, work, ldwork )
327 END IF
328*
329* W := W * T or W * T**T
330*
331 CALL dtrmm( 'Right', 'Upper', trans, 'Non-unit', m, k,
332 $ one, t, ldt, work, ldwork )
333*
334* C := C - W * V**T
335*
336 IF( n.GT.k ) THEN
337*
338* C2 := C2 - W * V2**T
339*
340 CALL dgemm( 'No transpose', 'Transpose', m, n-k, k,
341 $ -one, work, ldwork, v( k+1, 1 ), ldv, one,
342 $ c( 1, k+1 ), ldc )
343 END IF
344*
345* W := W * V1**T
346*
347 CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit', m, k,
348 $ one, v, ldv, work, ldwork )
349*
350* C1 := C1 - W
351*
352 DO 60 j = 1, k
353 DO 50 i = 1, m
354 c( i, j ) = c( i, j ) - work( i, j )
355 50 CONTINUE
356 60 CONTINUE
357 END IF
358*
359 ELSE
360*
361* Let V = ( V1 )
362* ( V2 ) (last K rows)
363* where V2 is unit upper triangular.
364*
365 IF( lsame( side, 'L' ) ) THEN
366*
367* Form H * C or H**T * C where C = ( C1 )
368* ( C2 )
369*
370* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK)
371*
372* W := C2**T
373*
374 DO 70 j = 1, k
375 CALL dcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
376 70 CONTINUE
377*
378* W := W * V2
379*
380 CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit', n,
381 $ k, one, v( m-k+1, 1 ), ldv, work, ldwork )
382 IF( m.GT.k ) THEN
383*
384* W := W + C1**T * V1
385*
386 CALL dgemm( 'Transpose', 'No transpose', n, k, m-k,
387 $ one, c, ldc, v, ldv, one, work, ldwork )
388 END IF
389*
390* W := W * T**T or W * T
391*
392 CALL dtrmm( 'Right', 'Lower', transt, 'Non-unit', n, k,
393 $ one, t, ldt, work, ldwork )
394*
395* C := C - V * W**T
396*
397 IF( m.GT.k ) THEN
398*
399* C1 := C1 - V1 * W**T
400*
401 CALL dgemm( 'No transpose', 'Transpose', m-k, n, k,
402 $ -one, v, ldv, work, ldwork, one, c, ldc )
403 END IF
404*
405* W := W * V2**T
406*
407 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit', n, k,
408 $ one, v( m-k+1, 1 ), ldv, work, ldwork )
409*
410* C2 := C2 - W**T
411*
412 DO 90 j = 1, k
413 DO 80 i = 1, n
414 c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
415 80 CONTINUE
416 90 CONTINUE
417*
418 ELSE IF( lsame( side, 'R' ) ) THEN
419*
420* Form C * H or C * H**T where C = ( C1 C2 )
421*
422* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
423*
424* W := C2
425*
426 DO 100 j = 1, k
427 CALL dcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
428 100 CONTINUE
429*
430* W := W * V2
431*
432 CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit', m,
433 $ k, one, v( n-k+1, 1 ), ldv, work, ldwork )
434 IF( n.GT.k ) THEN
435*
436* W := W + C1 * V1
437*
438 CALL dgemm( 'No transpose', 'No transpose', m, k, n-k,
439 $ one, c, ldc, v, ldv, one, work, ldwork )
440 END IF
441*
442* W := W * T or W * T**T
443*
444 CALL dtrmm( 'Right', 'Lower', trans, 'Non-unit', m, k,
445 $ one, t, ldt, work, ldwork )
446*
447* C := C - W * V**T
448*
449 IF( n.GT.k ) THEN
450*
451* C1 := C1 - W * V1**T
452*
453 CALL dgemm( 'No transpose', 'Transpose', m, n-k, k,
454 $ -one, work, ldwork, v, ldv, one, c, ldc )
455 END IF
456*
457* W := W * V2**T
458*
459 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit', m, k,
460 $ one, v( n-k+1, 1 ), ldv, work, ldwork )
461*
462* C2 := C2 - W
463*
464 DO 120 j = 1, k
465 DO 110 i = 1, m
466 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
467 110 CONTINUE
468 120 CONTINUE
469 END IF
470 END IF
471*
472 ELSE IF( lsame( storev, 'R' ) ) THEN
473*
474 IF( lsame( direct, 'F' ) ) THEN
475*
476* Let V = ( V1 V2 ) (V1: first K columns)
477* where V1 is unit upper triangular.
478*
479 IF( lsame( side, 'L' ) ) THEN
480*
481* Form H * C or H**T * C where C = ( C1 )
482* ( C2 )
483*
484* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
485*
486* W := C1**T
487*
488 DO 130 j = 1, k
489 CALL dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
490 130 CONTINUE
491*
492* W := W * V1**T
493*
494 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit', n, k,
495 $ one, v, ldv, work, ldwork )
496 IF( m.GT.k ) THEN
497*
498* W := W + C2**T * V2**T
499*
500 CALL dgemm( 'Transpose', 'Transpose', n, k, m-k, one,
501 $ c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one,
502 $ work, ldwork )
503 END IF
504*
505* W := W * T**T or W * T
506*
507 CALL dtrmm( 'Right', 'Upper', transt, 'Non-unit', n, k,
508 $ one, t, ldt, work, ldwork )
509*
510* C := C - V**T * W**T
511*
512 IF( m.GT.k ) THEN
513*
514* C2 := C2 - V2**T * W**T
515*
516 CALL dgemm( 'Transpose', 'Transpose', m-k, n, k, -one,
517 $ v( 1, k+1 ), ldv, work, ldwork, one,
518 $ c( k+1, 1 ), ldc )
519 END IF
520*
521* W := W * V1
522*
523 CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit', n,
524 $ k, one, v, ldv, work, ldwork )
525*
526* C1 := C1 - W**T
527*
528 DO 150 j = 1, k
529 DO 140 i = 1, n
530 c( j, i ) = c( j, i ) - work( i, j )
531 140 CONTINUE
532 150 CONTINUE
533*
534 ELSE IF( lsame( side, 'R' ) ) THEN
535*
536* Form C * H or C * H**T where C = ( C1 C2 )
537*
538* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
539*
540* W := C1
541*
542 DO 160 j = 1, k
543 CALL dcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
544 160 CONTINUE
545*
546* W := W * V1**T
547*
548 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Unit', m, k,
549 $ one, v, ldv, work, ldwork )
550 IF( n.GT.k ) THEN
551*
552* W := W + C2 * V2**T
553*
554 CALL dgemm( 'No transpose', 'Transpose', m, k, n-k,
555 $ one, c( 1, k+1 ), ldc, v( 1, k+1 ), ldv,
556 $ one, work, ldwork )
557 END IF
558*
559* W := W * T or W * T**T
560*
561 CALL dtrmm( 'Right', 'Upper', trans, 'Non-unit', m, k,
562 $ one, t, ldt, work, ldwork )
563*
564* C := C - W * V
565*
566 IF( n.GT.k ) THEN
567*
568* C2 := C2 - W * V2
569*
570 CALL dgemm( 'No transpose', 'No transpose', m, n-k, k,
571 $ -one, work, ldwork, v( 1, k+1 ), ldv, one,
572 $ c( 1, k+1 ), ldc )
573 END IF
574*
575* W := W * V1
576*
577 CALL dtrmm( 'Right', 'Upper', 'No transpose', 'Unit', m,
578 $ k, one, v, ldv, work, ldwork )
579*
580* C1 := C1 - W
581*
582 DO 180 j = 1, k
583 DO 170 i = 1, m
584 c( i, j ) = c( i, j ) - work( i, j )
585 170 CONTINUE
586 180 CONTINUE
587*
588 END IF
589*
590 ELSE
591*
592* Let V = ( V1 V2 ) (V2: last K columns)
593* where V2 is unit lower triangular.
594*
595 IF( lsame( side, 'L' ) ) THEN
596*
597* Form H * C or H**T * C where C = ( C1 )
598* ( C2 )
599*
600* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
601*
602* W := C2**T
603*
604 DO 190 j = 1, k
605 CALL dcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
606 190 CONTINUE
607*
608* W := W * V2**T
609*
610 CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit', n, k,
611 $ one, v( 1, m-k+1 ), ldv, work, ldwork )
612 IF( m.GT.k ) THEN
613*
614* W := W + C1**T * V1**T
615*
616 CALL dgemm( 'Transpose', 'Transpose', n, k, m-k, one,
617 $ c, ldc, v, ldv, one, work, ldwork )
618 END IF
619*
620* W := W * T**T or W * T
621*
622 CALL dtrmm( 'Right', 'Lower', transt, 'Non-unit', n, k,
623 $ one, t, ldt, work, ldwork )
624*
625* C := C - V**T * W**T
626*
627 IF( m.GT.k ) THEN
628*
629* C1 := C1 - V1**T * W**T
630*
631 CALL dgemm( 'Transpose', 'Transpose', m-k, n, k, -one,
632 $ v, ldv, work, ldwork, one, c, ldc )
633 END IF
634*
635* W := W * V2
636*
637 CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit', n,
638 $ k, one, v( 1, m-k+1 ), ldv, work, ldwork )
639*
640* C2 := C2 - W**T
641*
642 DO 210 j = 1, k
643 DO 200 i = 1, n
644 c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
645 200 CONTINUE
646 210 CONTINUE
647*
648 ELSE IF( lsame( side, 'R' ) ) THEN
649*
650* Form C * H or C * H' where C = ( C1 C2 )
651*
652* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK)
653*
654* W := C2
655*
656 DO 220 j = 1, k
657 CALL dcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
658 220 CONTINUE
659*
660* W := W * V2**T
661*
662 CALL dtrmm( 'Right', 'Lower', 'Transpose', 'Unit', m, k,
663 $ one, v( 1, n-k+1 ), ldv, work, ldwork )
664 IF( n.GT.k ) THEN
665*
666* W := W + C1 * V1**T
667*
668 CALL dgemm( 'No transpose', 'Transpose', m, k, n-k,
669 $ one, c, ldc, v, ldv, one, work, ldwork )
670 END IF
671*
672* W := W * T or W * T**T
673*
674 CALL dtrmm( 'Right', 'Lower', trans, 'Non-unit', m, k,
675 $ one, t, ldt, work, ldwork )
676*
677* C := C - W * V
678*
679 IF( n.GT.k ) THEN
680*
681* C1 := C1 - W * V1
682*
683 CALL dgemm( 'No transpose', 'No transpose', m, n-k, k,
684 $ -one, work, ldwork, v, ldv, one, c, ldc )
685 END IF
686*
687* W := W * V2
688*
689 CALL dtrmm( 'Right', 'Lower', 'No transpose', 'Unit', m,
690 $ k, one, v( 1, n-k+1 ), ldv, work, ldwork )
691*
692* C1 := C1 - W
693*
694 DO 240 j = 1, k
695 DO 230 i = 1, m
696 c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
697 230 CONTINUE
698 240 CONTINUE
699*
700 END IF
701*
702 END IF
703 END IF
704*
705 RETURN
706*
707* End of DLARFB
708*

◆ dlarfb_gett()

subroutine dlarfb_gett ( character ident,
integer m,
integer n,
integer k,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldwork, * ) work,
integer ldwork )

DLARFB_GETT

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

Purpose:
!>
!> DLARFB_GETT applies a real Householder block reflector H from the
!> left to a real (K+M)-by-N   matrix
!> composed of two block matrices: an upper trapezoidal K-by-N matrix A
!> stored in the array A, and a rectangular M-by-(N-K) matrix B, stored
!> in the array B. The block reflector H is stored in a compact
!> WY-representation, where the elementary reflectors are in the
!> arrays A, B and T. See Further Details section.
!>
Parameters
[in]IDENT
!>          IDENT is CHARACTER*1
!>          If IDENT = not 'I', or not 'i', then V1 is unit
!>             lower-triangular and stored in the left K-by-K block of
!>             the input matrix A,
!>          If IDENT = 'I' or 'i', then  V1 is an identity matrix and
!>             not stored.
!>          See Further Details section.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix B.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and B.
!>          N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number or rows of the matrix A.
!>          K is also order of the matrix T, i.e. the number of
!>          elementary reflectors whose product defines the block
!>          reflector. 0 <= K <= N.
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The upper-triangular K-by-K matrix T in the representation
!>          of the block reflector.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= K.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>
!>          On entry:
!>           a) In the K-by-N upper-trapezoidal part A: input matrix A.
!>           b) In the columns below the diagonal: columns of V1
!>              (ones are not stored on the diagonal).
!>
!>          On exit:
!>            A is overwritten by rectangular K-by-N product H*A.
!>
!>          See Further Details section.
!>
[in]LDA
!>          LDB is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,K).
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>
!>          On entry:
!>            a) In the M-by-(N-K) right block: input matrix B.
!>            b) In the M-by-N left block: columns of V2.
!>
!>          On exit:
!>            B is overwritten by rectangular M-by-N product H*B.
!>
!>          See Further Details section.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array,
!>          dimension (LDWORK,max(K,N-K))
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK. LDWORK>=max(1,K).
!>
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
!>
!> November 2020, Igor Kozachenko,
!>                Computer Science Division,
!>                University of California, Berkeley
!>
!>
Further Details:
!>
!>    (1) Description of the Algebraic Operation.
!>
!>    The matrix A is a K-by-N matrix composed of two column block
!>    matrices, A1, which is K-by-K, and A2, which is K-by-(N-K):
!>    A = ( A1, A2 ).
!>    The matrix B is an M-by-N matrix composed of two column block
!>    matrices, B1, which is M-by-K, and B2, which is M-by-(N-K):
!>    B = ( B1, B2 ).
!>
!>    Perform the operation:
!>
!>       ( A_out ) := H * ( A_in ) = ( I - V * T * V**T ) * ( A_in ) =
!>       ( B_out )        ( B_in )                          ( B_in )
!>                  = ( I - ( V1 ) * T * ( V1**T, V2**T ) ) * ( A_in )
!>                          ( V2 )                            ( B_in )
!>     On input:
!>
!>    a) ( A_in )  consists of two block columns:
!>       ( B_in )
!>
!>       ( A_in ) = (( A1_in ) ( A2_in )) = (( A1_in ) ( A2_in ))
!>       ( B_in )   (( B1_in ) ( B2_in ))   ((     0 ) ( B2_in )),
!>
!>       where the column blocks are:
!>
!>       (  A1_in )  is a K-by-K upper-triangular matrix stored in the
!>                   upper triangular part of the array A(1:K,1:K).
!>       (  B1_in )  is an M-by-K rectangular ZERO matrix and not stored.
!>
!>       ( A2_in )  is a K-by-(N-K) rectangular matrix stored
!>                  in the array A(1:K,K+1:N).
!>       ( B2_in )  is an M-by-(N-K) rectangular matrix stored
!>                  in the array B(1:M,K+1:N).
!>
!>    b) V = ( V1 )
!>           ( V2 )
!>
!>       where:
!>       1) if IDENT == 'I',V1 is a K-by-K identity matrix, not stored;
!>       2) if IDENT != 'I',V1 is a K-by-K unit lower-triangular matrix,
!>          stored in the lower-triangular part of the array
!>          A(1:K,1:K) (ones are not stored),
!>       and V2 is an M-by-K rectangular stored the array B(1:M,1:K),
!>                 (because on input B1_in is a rectangular zero
!>                  matrix that is not stored and the space is
!>                  used to store V2).
!>
!>    c) T is a K-by-K upper-triangular matrix stored
!>       in the array T(1:K,1:K).
!>
!>    On output:
!>
!>    a) ( A_out ) consists of two  block columns:
!>       ( B_out )
!>
!>       ( A_out ) = (( A1_out ) ( A2_out ))
!>       ( B_out )   (( B1_out ) ( B2_out )),
!>
!>       where the column blocks are:
!>
!>       ( A1_out )  is a K-by-K square matrix, or a K-by-K
!>                   upper-triangular matrix, if V1 is an
!>                   identity matrix. AiOut is stored in
!>                   the array A(1:K,1:K).
!>       ( B1_out )  is an M-by-K rectangular matrix stored
!>                   in the array B(1:M,K:N).
!>
!>       ( A2_out )  is a K-by-(N-K) rectangular matrix stored
!>                   in the array A(1:K,K+1:N).
!>       ( B2_out )  is an M-by-(N-K) rectangular matrix stored
!>                   in the array B(1:M,K+1:N).
!>
!>
!>    The operation above can be represented as the same operation
!>    on each block column:
!>
!>       ( A1_out ) := H * ( A1_in ) = ( I - V * T * V**T ) * ( A1_in )
!>       ( B1_out )        (     0 )                          (     0 )
!>
!>       ( A2_out ) := H * ( A2_in ) = ( I - V * T * V**T ) * ( A2_in )
!>       ( B2_out )        ( B2_in )                          ( B2_in )
!>
!>    If IDENT != 'I':
!>
!>       The computation for column block 1:
!>
!>       A1_out: = A1_in - V1*T*(V1**T)*A1_in
!>
!>       B1_out: = - V2*T*(V1**T)*A1_in
!>
!>       The computation for column block 2, which exists if N > K:
!>
!>       A2_out: = A2_in - V1*T*( (V1**T)*A2_in + (V2**T)*B2_in )
!>
!>       B2_out: = B2_in - V2*T*( (V1**T)*A2_in + (V2**T)*B2_in )
!>
!>    If IDENT == 'I':
!>
!>       The operation for column block 1:
!>
!>       A1_out: = A1_in - V1*T**A1_in
!>
!>       B1_out: = - V2*T**A1_in
!>
!>       The computation for column block 2, which exists if N > K:
!>
!>       A2_out: = A2_in - T*( A2_in + (V2**T)*B2_in )
!>
!>       B2_out: = B2_in - V2*T*( A2_in + (V2**T)*B2_in )
!>
!>    (2) Description of the Algorithmic Computation.
!>
!>    In the first step, we compute column block 2, i.e. A2 and B2.
!>    Here, we need to use the K-by-(N-K) rectangular workspace
!>    matrix W2 that is of the same size as the matrix A2.
!>    W2 is stored in the array WORK(1:K,1:(N-K)).
!>
!>    In the second step, we compute column block 1, i.e. A1 and B1.
!>    Here, we need to use the K-by-K square workspace matrix W1
!>    that is of the same size as the as the matrix A1.
!>    W1 is stored in the array WORK(1:K,1:K).
!>
!>    NOTE: Hence, in this routine, we need the workspace array WORK
!>    only of size WORK(1:K,1:max(K,N-K)) so it can hold both W2 from
!>    the first step and W1 from the second step.
!>
!>    Case (A), when V1 is unit lower-triangular, i.e. IDENT != 'I',
!>    more computations than in the Case (B).
!>
!>    if( IDENT != 'I' ) then
!>     if ( N > K ) then
!>       (First Step - column block 2)
!>       col2_(1) W2: = A2
!>       col2_(2) W2: = (V1**T) * W2 = (unit_lower_tr_of_(A1)**T) * W2
!>       col2_(3) W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2
!>       col2_(4) W2: = T * W2
!>       col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2
!>       col2_(6) W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2
!>       col2_(7) A2: = A2 - W2
!>     else
!>       (Second Step - column block 1)
!>       col1_(1) W1: = A1
!>       col1_(2) W1: = (V1**T) * W1 = (unit_lower_tr_of_(A1)**T) * W1
!>       col1_(3) W1: = T * W1
!>       col1_(4) B1: = - V2 * W1 = - B1 * W1
!>       col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1
!>       col1_(6) square A1: = A1 - W1
!>     end if
!>    end if
!>
!>    Case (B), when V1 is an identity matrix, i.e. IDENT == 'I',
!>    less computations than in the Case (A)
!>
!>    if( IDENT == 'I' ) then
!>     if ( N > K ) then
!>       (First Step - column block 2)
!>       col2_(1) W2: = A2
!>       col2_(3) W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2
!>       col2_(4) W2: = T * W2
!>       col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2
!>       col2_(7) A2: = A2 - W2
!>     else
!>       (Second Step - column block 1)
!>       col1_(1) W1: = A1
!>       col1_(3) W1: = T * W1
!>       col1_(4) B1: = - V2 * W1 = - B1 * W1
!>       col1_(6) upper-triangular_of_(A1): = A1 - W1
!>     end if
!>    end if
!>
!>    Combine these cases (A) and (B) together, this is the resulting
!>    algorithm:
!>
!>    if ( N > K ) then
!>
!>      (First Step - column block 2)
!>
!>      col2_(1)  W2: = A2
!>      if( IDENT != 'I' ) then
!>        col2_(2)  W2: = (V1**T) * W2
!>                      = (unit_lower_tr_of_(A1)**T) * W2
!>      end if
!>      col2_(3)  W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2]
!>      col2_(4)  W2: = T * W2
!>      col2_(5)  B2: = B2 - V2 * W2 = B2 - B1 * W2
!>      if( IDENT != 'I' ) then
!>        col2_(6)    W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2
!>      end if
!>      col2_(7) A2: = A2 - W2
!>
!>    else
!>
!>    (Second Step - column block 1)
!>
!>      col1_(1) W1: = A1
!>      if( IDENT != 'I' ) then
!>        col1_(2) W1: = (V1**T) * W1
!>                    = (unit_lower_tr_of_(A1)**T) * W1
!>      end if
!>      col1_(3) W1: = T * W1
!>      col1_(4) B1: = - V2 * W1 = - B1 * W1
!>      if( IDENT != 'I' ) then
!>        col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1
!>        col1_(6_a) below_diag_of_(A1): =  - below_diag_of_(W1)
!>      end if
!>      col1_(6_b) up_tr_of_(A1): = up_tr_of_(A1) - up_tr_of_(W1)
!>
!>    end if
!>
!>

Definition at line 390 of file dlarfb_gett.f.

392 IMPLICIT NONE
393*
394* -- LAPACK auxiliary routine --
395* -- LAPACK is a software package provided by Univ. of Tennessee, --
396* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
397*
398* .. Scalar Arguments ..
399 CHARACTER IDENT
400 INTEGER K, LDA, LDB, LDT, LDWORK, M, N
401* ..
402* .. Array Arguments ..
403 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ),
404 $ WORK( LDWORK, * )
405* ..
406*
407* =====================================================================
408*
409* .. Parameters ..
410 DOUBLE PRECISION ONE, ZERO
411 parameter( one = 1.0d+0, zero = 0.0d+0 )
412* ..
413* .. Local Scalars ..
414 LOGICAL LNOTIDENT
415 INTEGER I, J
416* ..
417* .. EXTERNAL FUNCTIONS ..
418 LOGICAL LSAME
419 EXTERNAL lsame
420* ..
421* .. External Subroutines ..
422 EXTERNAL dcopy, dgemm, dtrmm
423* ..
424* .. Executable Statements ..
425*
426* Quick return if possible
427*
428 IF( m.LT.0 .OR. n.LE.0 .OR. k.EQ.0 .OR. k.GT.n )
429 $ RETURN
430*
431 lnotident = .NOT.lsame( ident, 'I' )
432*
433* ------------------------------------------------------------------
434*
435* First Step. Computation of the Column Block 2:
436*
437* ( A2 ) := H * ( A2 )
438* ( B2 ) ( B2 )
439*
440* ------------------------------------------------------------------
441*
442 IF( n.GT.k ) THEN
443*
444* col2_(1) Compute W2: = A2. Therefore, copy A2 = A(1:K, K+1:N)
445* into W2=WORK(1:K, 1:N-K) column-by-column.
446*
447 DO j = 1, n-k
448 CALL dcopy( k, a( 1, k+j ), 1, work( 1, j ), 1 )
449 END DO
450
451 IF( lnotident ) THEN
452*
453* col2_(2) Compute W2: = (V1**T) * W2 = (A1**T) * W2,
454* V1 is not an identy matrix, but unit lower-triangular
455* V1 stored in A1 (diagonal ones are not stored).
456*
457*
458 CALL dtrmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,
459 $ work, ldwork )
460 END IF
461*
462* col2_(3) Compute W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2
463* V2 stored in B1.
464*
465 IF( m.GT.0 ) THEN
466 CALL dgemm( 'T', 'N', k, n-k, m, one, b, ldb,
467 $ b( 1, k+1 ), ldb, one, work, ldwork )
468 END IF
469*
470* col2_(4) Compute W2: = T * W2,
471* T is upper-triangular.
472*
473 CALL dtrmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,
474 $ work, ldwork )
475*
476* col2_(5) Compute B2: = B2 - V2 * W2 = B2 - B1 * W2,
477* V2 stored in B1.
478*
479 IF( m.GT.0 ) THEN
480 CALL dgemm( 'N', 'N', m, n-k, k, -one, b, ldb,
481 $ work, ldwork, one, b( 1, k+1 ), ldb )
482 END IF
483*
484 IF( lnotident ) THEN
485*
486* col2_(6) Compute W2: = V1 * W2 = A1 * W2,
487* V1 is not an identity matrix, but unit lower-triangular,
488* V1 stored in A1 (diagonal ones are not stored).
489*
490 CALL dtrmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,
491 $ work, ldwork )
492 END IF
493*
494* col2_(7) Compute A2: = A2 - W2 =
495* = A(1:K, K+1:N-K) - WORK(1:K, 1:N-K),
496* column-by-column.
497*
498 DO j = 1, n-k
499 DO i = 1, k
500 a( i, k+j ) = a( i, k+j ) - work( i, j )
501 END DO
502 END DO
503*
504 END IF
505*
506* ------------------------------------------------------------------
507*
508* Second Step. Computation of the Column Block 1:
509*
510* ( A1 ) := H * ( A1 )
511* ( B1 ) ( 0 )
512*
513* ------------------------------------------------------------------
514*
515* col1_(1) Compute W1: = A1. Copy the upper-triangular
516* A1 = A(1:K, 1:K) into the upper-triangular
517* W1 = WORK(1:K, 1:K) column-by-column.
518*
519 DO j = 1, k
520 CALL dcopy( j, a( 1, j ), 1, work( 1, j ), 1 )
521 END DO
522*
523* Set the subdiagonal elements of W1 to zero column-by-column.
524*
525 DO j = 1, k - 1
526 DO i = j + 1, k
527 work( i, j ) = zero
528 END DO
529 END DO
530*
531 IF( lnotident ) THEN
532*
533* col1_(2) Compute W1: = (V1**T) * W1 = (A1**T) * W1,
534* V1 is not an identity matrix, but unit lower-triangular
535* V1 stored in A1 (diagonal ones are not stored),
536* W1 is upper-triangular with zeroes below the diagonal.
537*
538 CALL dtrmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,
539 $ work, ldwork )
540 END IF
541*
542* col1_(3) Compute W1: = T * W1,
543* T is upper-triangular,
544* W1 is upper-triangular with zeroes below the diagonal.
545*
546 CALL dtrmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,
547 $ work, ldwork )
548*
549* col1_(4) Compute B1: = - V2 * W1 = - B1 * W1,
550* V2 = B1, W1 is upper-triangular with zeroes below the diagonal.
551*
552 IF( m.GT.0 ) THEN
553 CALL dtrmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,
554 $ b, ldb )
555 END IF
556*
557 IF( lnotident ) THEN
558*
559* col1_(5) Compute W1: = V1 * W1 = A1 * W1,
560* V1 is not an identity matrix, but unit lower-triangular
561* V1 stored in A1 (diagonal ones are not stored),
562* W1 is upper-triangular on input with zeroes below the diagonal,
563* and square on output.
564*
565 CALL dtrmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,
566 $ work, ldwork )
567*
568* col1_(6) Compute A1: = A1 - W1 = A(1:K, 1:K) - WORK(1:K, 1:K)
569* column-by-column. A1 is upper-triangular on input.
570* If IDENT, A1 is square on output, and W1 is square,
571* if NOT IDENT, A1 is upper-triangular on output,
572* W1 is upper-triangular.
573*
574* col1_(6)_a Compute elements of A1 below the diagonal.
575*
576 DO j = 1, k - 1
577 DO i = j + 1, k
578 a( i, j ) = - work( i, j )
579 END DO
580 END DO
581*
582 END IF
583*
584* col1_(6)_b Compute elements of A1 on and above the diagonal.
585*
586 DO j = 1, k
587 DO i = 1, j
588 a( i, j ) = a( i, j ) - work( i, j )
589 END DO
590 END DO
591*
592 RETURN
593*
594* End of DLARFB_GETT
595*

◆ dlarfg()

subroutine dlarfg ( integer n,
double precision alpha,
double precision, dimension( * ) x,
integer incx,
double precision tau )

DLARFG generates an elementary reflector (Householder matrix).

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

Purpose:
!>
!> DLARFG generates a real elementary reflector H of order n, such
!> that
!>
!>       H * ( alpha ) = ( beta ),   H**T * H = I.
!>           (   x   )   (   0  )
!>
!> where alpha and beta are scalars, and x is an (n-1)-element real
!> vector. H is represented in the form
!>
!>       H = I - tau * ( 1 ) * ( 1 v**T ) ,
!>                     ( v )
!>
!> where tau is a real scalar and v is a real (n-1)-element
!> vector.
!>
!> If the elements of x are all zero, then tau = 0 and H is taken to be
!> the unit matrix.
!>
!> Otherwise  1 <= tau <= 2.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the elementary reflector.
!>
[in,out]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension
!>                         (1+(N-2)*abs(INCX))
!>          On entry, the vector x.
!>          On exit, it is overwritten with the vector v.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file dlarfg.f.

106*
107* -- LAPACK auxiliary routine --
108* -- LAPACK is a software package provided by Univ. of Tennessee, --
109* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
110*
111* .. Scalar Arguments ..
112 INTEGER INCX, N
113 DOUBLE PRECISION ALPHA, TAU
114* ..
115* .. Array Arguments ..
116 DOUBLE PRECISION X( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 DOUBLE PRECISION ONE, ZERO
123 parameter( one = 1.0d+0, zero = 0.0d+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER J, KNT
127 DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
128* ..
129* .. External Functions ..
130 DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
131 EXTERNAL dlamch, dlapy2, dnrm2
132* ..
133* .. Intrinsic Functions ..
134 INTRINSIC abs, sign
135* ..
136* .. External Subroutines ..
137 EXTERNAL dscal
138* ..
139* .. Executable Statements ..
140*
141 IF( n.LE.1 ) THEN
142 tau = zero
143 RETURN
144 END IF
145*
146 xnorm = dnrm2( n-1, x, incx )
147*
148 IF( xnorm.EQ.zero ) THEN
149*
150* H = I
151*
152 tau = zero
153 ELSE
154*
155* general case
156*
157 beta = -sign( dlapy2( alpha, xnorm ), alpha )
158 safmin = dlamch( 'S' ) / dlamch( 'E' )
159 knt = 0
160 IF( abs( beta ).LT.safmin ) THEN
161*
162* XNORM, BETA may be inaccurate; scale X and recompute them
163*
164 rsafmn = one / safmin
165 10 CONTINUE
166 knt = knt + 1
167 CALL dscal( n-1, rsafmn, x, incx )
168 beta = beta*rsafmn
169 alpha = alpha*rsafmn
170 IF( (abs( beta ).LT.safmin) .AND. (knt .LT. 20) )
171 $ GO TO 10
172*
173* New BETA is at most 1, at least SAFMIN
174*
175 xnorm = dnrm2( n-1, x, incx )
176 beta = -sign( dlapy2( alpha, xnorm ), alpha )
177 END IF
178 tau = ( beta-alpha ) / beta
179 CALL dscal( n-1, one / ( alpha-beta ), x, incx )
180*
181* If ALPHA is subnormal, it may lose relative accuracy
182*
183 DO 20 j = 1, knt
184 beta = beta*safmin
185 20 CONTINUE
186 alpha = beta
187 END IF
188*
189 RETURN
190*
191* End of DLARFG
192*

◆ dlarfgp()

subroutine dlarfgp ( integer n,
double precision alpha,
double precision, dimension( * ) x,
integer incx,
double precision tau )

DLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.

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

Purpose:
!>
!> DLARFGP generates a real elementary reflector H of order n, such
!> that
!>
!>       H * ( alpha ) = ( beta ),   H**T * H = I.
!>           (   x   )   (   0  )
!>
!> where alpha and beta are scalars, beta is non-negative, and x is
!> an (n-1)-element real vector.  H is represented in the form
!>
!>       H = I - tau * ( 1 ) * ( 1 v**T ) ,
!>                     ( v )
!>
!> where tau is a real scalar and v is a real (n-1)-element
!> vector.
!>
!> If the elements of x are all zero, then tau = 0 and H is taken to be
!> the unit matrix.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the elementary reflector.
!>
[in,out]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension
!>                         (1+(N-2)*abs(INCX))
!>          On entry, the vector x.
!>          On exit, it is overwritten with the vector v.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dlarfgp.f.

104*
105* -- LAPACK auxiliary routine --
106* -- LAPACK is a software package provided by Univ. of Tennessee, --
107* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
108*
109* .. Scalar Arguments ..
110 INTEGER INCX, N
111 DOUBLE PRECISION ALPHA, TAU
112* ..
113* .. Array Arguments ..
114 DOUBLE PRECISION X( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 DOUBLE PRECISION TWO, ONE, ZERO
121 parameter( two = 2.0d+0, one = 1.0d+0, zero = 0.0d+0 )
122* ..
123* .. Local Scalars ..
124 INTEGER J, KNT
125 DOUBLE PRECISION BETA, BIGNUM, SAVEALPHA, SMLNUM, XNORM
126* ..
127* .. External Functions ..
128 DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
129 EXTERNAL dlamch, dlapy2, dnrm2
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, sign
133* ..
134* .. External Subroutines ..
135 EXTERNAL dscal
136* ..
137* .. Executable Statements ..
138*
139 IF( n.LE.0 ) THEN
140 tau = zero
141 RETURN
142 END IF
143*
144 xnorm = dnrm2( n-1, x, incx )
145*
146 IF( xnorm.EQ.zero ) THEN
147*
148* H = [+/-1, 0; I], sign chosen so ALPHA >= 0
149*
150 IF( alpha.GE.zero ) THEN
151* When TAU.eq.ZERO, the vector is special-cased to be
152* all zeros in the application routines. We do not need
153* to clear it.
154 tau = zero
155 ELSE
156* However, the application routines rely on explicit
157* zero checks when TAU.ne.ZERO, and we must clear X.
158 tau = two
159 DO j = 1, n-1
160 x( 1 + (j-1)*incx ) = 0
161 END DO
162 alpha = -alpha
163 END IF
164 ELSE
165*
166* general case
167*
168 beta = sign( dlapy2( alpha, xnorm ), alpha )
169 smlnum = dlamch( 'S' ) / dlamch( 'E' )
170 knt = 0
171 IF( abs( beta ).LT.smlnum ) THEN
172*
173* XNORM, BETA may be inaccurate; scale X and recompute them
174*
175 bignum = one / smlnum
176 10 CONTINUE
177 knt = knt + 1
178 CALL dscal( n-1, bignum, x, incx )
179 beta = beta*bignum
180 alpha = alpha*bignum
181 IF( (abs( beta ).LT.smlnum) .AND. (knt .LT. 20) )
182 $ GO TO 10
183*
184* New BETA is at most 1, at least SMLNUM
185*
186 xnorm = dnrm2( n-1, x, incx )
187 beta = sign( dlapy2( alpha, xnorm ), alpha )
188 END IF
189 savealpha = alpha
190 alpha = alpha + beta
191 IF( beta.LT.zero ) THEN
192 beta = -beta
193 tau = -alpha / beta
194 ELSE
195 alpha = xnorm * (xnorm/alpha)
196 tau = alpha / beta
197 alpha = -alpha
198 END IF
199*
200 IF ( abs(tau).LE.smlnum ) THEN
201*
202* In the case where the computed TAU ends up being a denormalized number,
203* it loses relative accuracy. This is a BIG problem. Solution: flush TAU
204* to ZERO. This explains the next IF statement.
205*
206* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.)
207* (Thanks Pat. Thanks MathWorks.)
208*
209 IF( savealpha.GE.zero ) THEN
210 tau = zero
211 ELSE
212 tau = two
213 DO j = 1, n-1
214 x( 1 + (j-1)*incx ) = 0
215 END DO
216 beta = -savealpha
217 END IF
218*
219 ELSE
220*
221* This is the general case.
222*
223 CALL dscal( n-1, one / alpha, x, incx )
224*
225 END IF
226*
227* If BETA is subnormal, it may lose relative accuracy
228*
229 DO 20 j = 1, knt
230 beta = beta*smlnum
231 20 CONTINUE
232 alpha = beta
233 END IF
234*
235 RETURN
236*
237* End of DLARFGP
238*

◆ dlarft()

subroutine dlarft ( character direct,
character storev,
integer n,
integer k,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( * ) tau,
double precision, dimension( ldt, * ) t,
integer ldt )

DLARFT forms the triangular factor T of a block reflector H = I - vtvH

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

Purpose:
!>
!> DLARFT forms the triangular factor T of a real block reflector H
!> of order n, which is defined as a product of k elementary reflectors.
!>
!> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!>
!> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!>
!> If STOREV = 'C', the vector which defines the elementary reflector
!> H(i) is stored in the i-th column of the array V, and
!>
!>    H  =  I - V * T * V**T
!>
!> If STOREV = 'R', the vector which defines the elementary reflector
!> H(i) is stored in the i-th row of the array V, and
!>
!>    H  =  I - V**T * T * V
!>
Parameters
[in]DIRECT
!>          DIRECT is CHARACTER*1
!>          Specifies the order in which the elementary reflectors are
!>          multiplied to form the block reflector:
!>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
!>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!>
[in]STOREV
!>          STOREV is CHARACTER*1
!>          Specifies how the vectors which define the elementary
!>          reflectors are stored (see also Further Details):
!>          = 'C': columnwise
!>          = 'R': rowwise
!>
[in]N
!>          N is INTEGER
!>          The order of the block reflector H. N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The order of the triangular factor T (= the number of
!>          elementary reflectors). K >= 1.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                               (LDV,K) if STOREV = 'C'
!>                               (LDV,N) if STOREV = 'R'
!>          The matrix V. See further details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i).
!>
[out]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The k by k triangular factor T of the block reflector.
!>          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
!>          lower triangular. The rest of the array is not used.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= K.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The shape of the matrix V and the storage of the vectors which define
!>  the H(i) is best illustrated by the following example with n = 5 and
!>  k = 3. The elements equal to 1 are not stored.
!>
!>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
!>
!>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
!>                   ( v1  1    )                     (     1 v2 v2 v2 )
!>                   ( v1 v2  1 )                     (        1 v3 v3 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!>
!>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
!>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
!>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
!>                   (     1 v3 )
!>                   (        1 )
!>

Definition at line 162 of file dlarft.f.

163*
164* -- LAPACK auxiliary 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 CHARACTER DIRECT, STOREV
170 INTEGER K, LDT, LDV, N
171* ..
172* .. Array Arguments ..
173 DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 DOUBLE PRECISION ONE, ZERO
180 parameter( one = 1.0d+0, zero = 0.0d+0 )
181* ..
182* .. Local Scalars ..
183 INTEGER I, J, PREVLASTV, LASTV
184* ..
185* .. External Subroutines ..
186 EXTERNAL dgemv, dtrmv
187* ..
188* .. External Functions ..
189 LOGICAL LSAME
190 EXTERNAL lsame
191* ..
192* .. Executable Statements ..
193*
194* Quick return if possible
195*
196 IF( n.EQ.0 )
197 $ RETURN
198*
199 IF( lsame( direct, 'F' ) ) THEN
200 prevlastv = n
201 DO i = 1, k
202 prevlastv = max( i, prevlastv )
203 IF( tau( i ).EQ.zero ) THEN
204*
205* H(i) = I
206*
207 DO j = 1, i
208 t( j, i ) = zero
209 END DO
210 ELSE
211*
212* general case
213*
214 IF( lsame( storev, 'C' ) ) THEN
215* Skip any trailing zeros.
216 DO lastv = n, i+1, -1
217 IF( v( lastv, i ).NE.zero ) EXIT
218 END DO
219 DO j = 1, i-1
220 t( j, i ) = -tau( i ) * v( i , j )
221 END DO
222 j = min( lastv, prevlastv )
223*
224* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i)
225*
226 CALL dgemv( 'Transpose', j-i, i-1, -tau( i ),
227 $ v( i+1, 1 ), ldv, v( i+1, i ), 1, one,
228 $ t( 1, i ), 1 )
229 ELSE
230* Skip any trailing zeros.
231 DO lastv = n, i+1, -1
232 IF( v( i, lastv ).NE.zero ) EXIT
233 END DO
234 DO j = 1, i-1
235 t( j, i ) = -tau( i ) * v( j , i )
236 END DO
237 j = min( lastv, prevlastv )
238*
239* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T
240*
241 CALL dgemv( 'No transpose', i-1, j-i, -tau( i ),
242 $ v( 1, i+1 ), ldv, v( i, i+1 ), ldv, one,
243 $ t( 1, i ), 1 )
244 END IF
245*
246* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
247*
248 CALL dtrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t,
249 $ ldt, t( 1, i ), 1 )
250 t( i, i ) = tau( i )
251 IF( i.GT.1 ) THEN
252 prevlastv = max( prevlastv, lastv )
253 ELSE
254 prevlastv = lastv
255 END IF
256 END IF
257 END DO
258 ELSE
259 prevlastv = 1
260 DO i = k, 1, -1
261 IF( tau( i ).EQ.zero ) THEN
262*
263* H(i) = I
264*
265 DO j = i, k
266 t( j, i ) = zero
267 END DO
268 ELSE
269*
270* general case
271*
272 IF( i.LT.k ) THEN
273 IF( lsame( storev, 'C' ) ) THEN
274* Skip any leading zeros.
275 DO lastv = 1, i-1
276 IF( v( lastv, i ).NE.zero ) EXIT
277 END DO
278 DO j = i+1, k
279 t( j, i ) = -tau( i ) * v( n-k+i , j )
280 END DO
281 j = max( lastv, prevlastv )
282*
283* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i)
284*
285 CALL dgemv( 'Transpose', n-k+i-j, k-i, -tau( i ),
286 $ v( j, i+1 ), ldv, v( j, i ), 1, one,
287 $ t( i+1, i ), 1 )
288 ELSE
289* Skip any leading zeros.
290 DO lastv = 1, i-1
291 IF( v( i, lastv ).NE.zero ) EXIT
292 END DO
293 DO j = i+1, k
294 t( j, i ) = -tau( i ) * v( j, n-k+i )
295 END DO
296 j = max( lastv, prevlastv )
297*
298* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T
299*
300 CALL dgemv( 'No transpose', k-i, n-k+i-j,
301 $ -tau( i ), v( i+1, j ), ldv, v( i, j ), ldv,
302 $ one, t( i+1, i ), 1 )
303 END IF
304*
305* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
306*
307 CALL dtrmv( 'Lower', 'No transpose', 'Non-unit', k-i,
308 $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
309 IF( i.GT.1 ) THEN
310 prevlastv = min( prevlastv, lastv )
311 ELSE
312 prevlastv = lastv
313 END IF
314 END IF
315 t( i, i ) = tau( i )
316 END IF
317 END DO
318 END IF
319 RETURN
320*
321* End of DLARFT
322*

◆ dlarfx()

subroutine dlarfx ( character side,
integer m,
integer n,
double precision, dimension( * ) v,
double precision tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work )

DLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.

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

Purpose:
!>
!> DLARFX applies a real elementary reflector H to a real m by n
!> matrix C, from either the left or the right. H is represented in the
!> form
!>
!>       H = I - tau * v * v**T
!>
!> where tau is a real scalar and v is a real vector.
!>
!> If tau = 0, then H is taken to be the unit matrix
!>
!> This version uses inline code if H has order < 11.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': form  H * C
!>          = 'R': form  C * H
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix C.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix C.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension (M) if SIDE = 'L'
!>                                     or (N) if SIDE = 'R'
!>          The vector v in the representation of H.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>          On entry, the m by n matrix C.
!>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
!>          or C * H if SIDE = 'R'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= (1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (N) if SIDE = 'L'
!>                      or (M) if SIDE = 'R'
!>          WORK is not referenced if H has order < 11.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file dlarfx.f.

120*
121* -- LAPACK auxiliary routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 CHARACTER SIDE
127 INTEGER LDC, M, N
128 DOUBLE PRECISION TAU
129* ..
130* .. Array Arguments ..
131 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 DOUBLE PRECISION ZERO, ONE
138 parameter( zero = 0.0d+0, one = 1.0d+0 )
139* ..
140* .. Local Scalars ..
141 INTEGER J
142 DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
143 $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
144* ..
145* .. External Functions ..
146 LOGICAL LSAME
147 EXTERNAL lsame
148* ..
149* .. External Subroutines ..
150 EXTERNAL dlarf
151* ..
152* .. Executable Statements ..
153*
154 IF( tau.EQ.zero )
155 $ RETURN
156 IF( lsame( side, 'L' ) ) THEN
157*
158* Form H * C, where H has order m.
159*
160 GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
161 $ 170, 190 )m
162*
163* Code for general M
164*
165 CALL dlarf( side, m, n, v, 1, tau, c, ldc, work )
166 GO TO 410
167 10 CONTINUE
168*
169* Special code for 1 x 1 Householder
170*
171 t1 = one - tau*v( 1 )*v( 1 )
172 DO 20 j = 1, n
173 c( 1, j ) = t1*c( 1, j )
174 20 CONTINUE
175 GO TO 410
176 30 CONTINUE
177*
178* Special code for 2 x 2 Householder
179*
180 v1 = v( 1 )
181 t1 = tau*v1
182 v2 = v( 2 )
183 t2 = tau*v2
184 DO 40 j = 1, n
185 sum = v1*c( 1, j ) + v2*c( 2, j )
186 c( 1, j ) = c( 1, j ) - sum*t1
187 c( 2, j ) = c( 2, j ) - sum*t2
188 40 CONTINUE
189 GO TO 410
190 50 CONTINUE
191*
192* Special code for 3 x 3 Householder
193*
194 v1 = v( 1 )
195 t1 = tau*v1
196 v2 = v( 2 )
197 t2 = tau*v2
198 v3 = v( 3 )
199 t3 = tau*v3
200 DO 60 j = 1, n
201 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j )
202 c( 1, j ) = c( 1, j ) - sum*t1
203 c( 2, j ) = c( 2, j ) - sum*t2
204 c( 3, j ) = c( 3, j ) - sum*t3
205 60 CONTINUE
206 GO TO 410
207 70 CONTINUE
208*
209* Special code for 4 x 4 Householder
210*
211 v1 = v( 1 )
212 t1 = tau*v1
213 v2 = v( 2 )
214 t2 = tau*v2
215 v3 = v( 3 )
216 t3 = tau*v3
217 v4 = v( 4 )
218 t4 = tau*v4
219 DO 80 j = 1, n
220 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
221 $ v4*c( 4, j )
222 c( 1, j ) = c( 1, j ) - sum*t1
223 c( 2, j ) = c( 2, j ) - sum*t2
224 c( 3, j ) = c( 3, j ) - sum*t3
225 c( 4, j ) = c( 4, j ) - sum*t4
226 80 CONTINUE
227 GO TO 410
228 90 CONTINUE
229*
230* Special code for 5 x 5 Householder
231*
232 v1 = v( 1 )
233 t1 = tau*v1
234 v2 = v( 2 )
235 t2 = tau*v2
236 v3 = v( 3 )
237 t3 = tau*v3
238 v4 = v( 4 )
239 t4 = tau*v4
240 v5 = v( 5 )
241 t5 = tau*v5
242 DO 100 j = 1, n
243 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
244 $ v4*c( 4, j ) + v5*c( 5, j )
245 c( 1, j ) = c( 1, j ) - sum*t1
246 c( 2, j ) = c( 2, j ) - sum*t2
247 c( 3, j ) = c( 3, j ) - sum*t3
248 c( 4, j ) = c( 4, j ) - sum*t4
249 c( 5, j ) = c( 5, j ) - sum*t5
250 100 CONTINUE
251 GO TO 410
252 110 CONTINUE
253*
254* Special code for 6 x 6 Householder
255*
256 v1 = v( 1 )
257 t1 = tau*v1
258 v2 = v( 2 )
259 t2 = tau*v2
260 v3 = v( 3 )
261 t3 = tau*v3
262 v4 = v( 4 )
263 t4 = tau*v4
264 v5 = v( 5 )
265 t5 = tau*v5
266 v6 = v( 6 )
267 t6 = tau*v6
268 DO 120 j = 1, n
269 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
270 $ v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j )
271 c( 1, j ) = c( 1, j ) - sum*t1
272 c( 2, j ) = c( 2, j ) - sum*t2
273 c( 3, j ) = c( 3, j ) - sum*t3
274 c( 4, j ) = c( 4, j ) - sum*t4
275 c( 5, j ) = c( 5, j ) - sum*t5
276 c( 6, j ) = c( 6, j ) - sum*t6
277 120 CONTINUE
278 GO TO 410
279 130 CONTINUE
280*
281* Special code for 7 x 7 Householder
282*
283 v1 = v( 1 )
284 t1 = tau*v1
285 v2 = v( 2 )
286 t2 = tau*v2
287 v3 = v( 3 )
288 t3 = tau*v3
289 v4 = v( 4 )
290 t4 = tau*v4
291 v5 = v( 5 )
292 t5 = tau*v5
293 v6 = v( 6 )
294 t6 = tau*v6
295 v7 = v( 7 )
296 t7 = tau*v7
297 DO 140 j = 1, n
298 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
299 $ v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) +
300 $ v7*c( 7, j )
301 c( 1, j ) = c( 1, j ) - sum*t1
302 c( 2, j ) = c( 2, j ) - sum*t2
303 c( 3, j ) = c( 3, j ) - sum*t3
304 c( 4, j ) = c( 4, j ) - sum*t4
305 c( 5, j ) = c( 5, j ) - sum*t5
306 c( 6, j ) = c( 6, j ) - sum*t6
307 c( 7, j ) = c( 7, j ) - sum*t7
308 140 CONTINUE
309 GO TO 410
310 150 CONTINUE
311*
312* Special code for 8 x 8 Householder
313*
314 v1 = v( 1 )
315 t1 = tau*v1
316 v2 = v( 2 )
317 t2 = tau*v2
318 v3 = v( 3 )
319 t3 = tau*v3
320 v4 = v( 4 )
321 t4 = tau*v4
322 v5 = v( 5 )
323 t5 = tau*v5
324 v6 = v( 6 )
325 t6 = tau*v6
326 v7 = v( 7 )
327 t7 = tau*v7
328 v8 = v( 8 )
329 t8 = tau*v8
330 DO 160 j = 1, n
331 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
332 $ v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) +
333 $ v7*c( 7, j ) + v8*c( 8, j )
334 c( 1, j ) = c( 1, j ) - sum*t1
335 c( 2, j ) = c( 2, j ) - sum*t2
336 c( 3, j ) = c( 3, j ) - sum*t3
337 c( 4, j ) = c( 4, j ) - sum*t4
338 c( 5, j ) = c( 5, j ) - sum*t5
339 c( 6, j ) = c( 6, j ) - sum*t6
340 c( 7, j ) = c( 7, j ) - sum*t7
341 c( 8, j ) = c( 8, j ) - sum*t8
342 160 CONTINUE
343 GO TO 410
344 170 CONTINUE
345*
346* Special code for 9 x 9 Householder
347*
348 v1 = v( 1 )
349 t1 = tau*v1
350 v2 = v( 2 )
351 t2 = tau*v2
352 v3 = v( 3 )
353 t3 = tau*v3
354 v4 = v( 4 )
355 t4 = tau*v4
356 v5 = v( 5 )
357 t5 = tau*v5
358 v6 = v( 6 )
359 t6 = tau*v6
360 v7 = v( 7 )
361 t7 = tau*v7
362 v8 = v( 8 )
363 t8 = tau*v8
364 v9 = v( 9 )
365 t9 = tau*v9
366 DO 180 j = 1, n
367 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
368 $ v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) +
369 $ v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j )
370 c( 1, j ) = c( 1, j ) - sum*t1
371 c( 2, j ) = c( 2, j ) - sum*t2
372 c( 3, j ) = c( 3, j ) - sum*t3
373 c( 4, j ) = c( 4, j ) - sum*t4
374 c( 5, j ) = c( 5, j ) - sum*t5
375 c( 6, j ) = c( 6, j ) - sum*t6
376 c( 7, j ) = c( 7, j ) - sum*t7
377 c( 8, j ) = c( 8, j ) - sum*t8
378 c( 9, j ) = c( 9, j ) - sum*t9
379 180 CONTINUE
380 GO TO 410
381 190 CONTINUE
382*
383* Special code for 10 x 10 Householder
384*
385 v1 = v( 1 )
386 t1 = tau*v1
387 v2 = v( 2 )
388 t2 = tau*v2
389 v3 = v( 3 )
390 t3 = tau*v3
391 v4 = v( 4 )
392 t4 = tau*v4
393 v5 = v( 5 )
394 t5 = tau*v5
395 v6 = v( 6 )
396 t6 = tau*v6
397 v7 = v( 7 )
398 t7 = tau*v7
399 v8 = v( 8 )
400 t8 = tau*v8
401 v9 = v( 9 )
402 t9 = tau*v9
403 v10 = v( 10 )
404 t10 = tau*v10
405 DO 200 j = 1, n
406 sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +
407 $ v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) +
408 $ v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j ) +
409 $ v10*c( 10, j )
410 c( 1, j ) = c( 1, j ) - sum*t1
411 c( 2, j ) = c( 2, j ) - sum*t2
412 c( 3, j ) = c( 3, j ) - sum*t3
413 c( 4, j ) = c( 4, j ) - sum*t4
414 c( 5, j ) = c( 5, j ) - sum*t5
415 c( 6, j ) = c( 6, j ) - sum*t6
416 c( 7, j ) = c( 7, j ) - sum*t7
417 c( 8, j ) = c( 8, j ) - sum*t8
418 c( 9, j ) = c( 9, j ) - sum*t9
419 c( 10, j ) = c( 10, j ) - sum*t10
420 200 CONTINUE
421 GO TO 410
422 ELSE
423*
424* Form C * H, where H has order n.
425*
426 GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
427 $ 370, 390 )n
428*
429* Code for general N
430*
431 CALL dlarf( side, m, n, v, 1, tau, c, ldc, work )
432 GO TO 410
433 210 CONTINUE
434*
435* Special code for 1 x 1 Householder
436*
437 t1 = one - tau*v( 1 )*v( 1 )
438 DO 220 j = 1, m
439 c( j, 1 ) = t1*c( j, 1 )
440 220 CONTINUE
441 GO TO 410
442 230 CONTINUE
443*
444* Special code for 2 x 2 Householder
445*
446 v1 = v( 1 )
447 t1 = tau*v1
448 v2 = v( 2 )
449 t2 = tau*v2
450 DO 240 j = 1, m
451 sum = v1*c( j, 1 ) + v2*c( j, 2 )
452 c( j, 1 ) = c( j, 1 ) - sum*t1
453 c( j, 2 ) = c( j, 2 ) - sum*t2
454 240 CONTINUE
455 GO TO 410
456 250 CONTINUE
457*
458* Special code for 3 x 3 Householder
459*
460 v1 = v( 1 )
461 t1 = tau*v1
462 v2 = v( 2 )
463 t2 = tau*v2
464 v3 = v( 3 )
465 t3 = tau*v3
466 DO 260 j = 1, m
467 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 )
468 c( j, 1 ) = c( j, 1 ) - sum*t1
469 c( j, 2 ) = c( j, 2 ) - sum*t2
470 c( j, 3 ) = c( j, 3 ) - sum*t3
471 260 CONTINUE
472 GO TO 410
473 270 CONTINUE
474*
475* Special code for 4 x 4 Householder
476*
477 v1 = v( 1 )
478 t1 = tau*v1
479 v2 = v( 2 )
480 t2 = tau*v2
481 v3 = v( 3 )
482 t3 = tau*v3
483 v4 = v( 4 )
484 t4 = tau*v4
485 DO 280 j = 1, m
486 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
487 $ v4*c( j, 4 )
488 c( j, 1 ) = c( j, 1 ) - sum*t1
489 c( j, 2 ) = c( j, 2 ) - sum*t2
490 c( j, 3 ) = c( j, 3 ) - sum*t3
491 c( j, 4 ) = c( j, 4 ) - sum*t4
492 280 CONTINUE
493 GO TO 410
494 290 CONTINUE
495*
496* Special code for 5 x 5 Householder
497*
498 v1 = v( 1 )
499 t1 = tau*v1
500 v2 = v( 2 )
501 t2 = tau*v2
502 v3 = v( 3 )
503 t3 = tau*v3
504 v4 = v( 4 )
505 t4 = tau*v4
506 v5 = v( 5 )
507 t5 = tau*v5
508 DO 300 j = 1, m
509 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
510 $ v4*c( j, 4 ) + v5*c( j, 5 )
511 c( j, 1 ) = c( j, 1 ) - sum*t1
512 c( j, 2 ) = c( j, 2 ) - sum*t2
513 c( j, 3 ) = c( j, 3 ) - sum*t3
514 c( j, 4 ) = c( j, 4 ) - sum*t4
515 c( j, 5 ) = c( j, 5 ) - sum*t5
516 300 CONTINUE
517 GO TO 410
518 310 CONTINUE
519*
520* Special code for 6 x 6 Householder
521*
522 v1 = v( 1 )
523 t1 = tau*v1
524 v2 = v( 2 )
525 t2 = tau*v2
526 v3 = v( 3 )
527 t3 = tau*v3
528 v4 = v( 4 )
529 t4 = tau*v4
530 v5 = v( 5 )
531 t5 = tau*v5
532 v6 = v( 6 )
533 t6 = tau*v6
534 DO 320 j = 1, m
535 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
536 $ v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 )
537 c( j, 1 ) = c( j, 1 ) - sum*t1
538 c( j, 2 ) = c( j, 2 ) - sum*t2
539 c( j, 3 ) = c( j, 3 ) - sum*t3
540 c( j, 4 ) = c( j, 4 ) - sum*t4
541 c( j, 5 ) = c( j, 5 ) - sum*t5
542 c( j, 6 ) = c( j, 6 ) - sum*t6
543 320 CONTINUE
544 GO TO 410
545 330 CONTINUE
546*
547* Special code for 7 x 7 Householder
548*
549 v1 = v( 1 )
550 t1 = tau*v1
551 v2 = v( 2 )
552 t2 = tau*v2
553 v3 = v( 3 )
554 t3 = tau*v3
555 v4 = v( 4 )
556 t4 = tau*v4
557 v5 = v( 5 )
558 t5 = tau*v5
559 v6 = v( 6 )
560 t6 = tau*v6
561 v7 = v( 7 )
562 t7 = tau*v7
563 DO 340 j = 1, m
564 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
565 $ v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) +
566 $ v7*c( j, 7 )
567 c( j, 1 ) = c( j, 1 ) - sum*t1
568 c( j, 2 ) = c( j, 2 ) - sum*t2
569 c( j, 3 ) = c( j, 3 ) - sum*t3
570 c( j, 4 ) = c( j, 4 ) - sum*t4
571 c( j, 5 ) = c( j, 5 ) - sum*t5
572 c( j, 6 ) = c( j, 6 ) - sum*t6
573 c( j, 7 ) = c( j, 7 ) - sum*t7
574 340 CONTINUE
575 GO TO 410
576 350 CONTINUE
577*
578* Special code for 8 x 8 Householder
579*
580 v1 = v( 1 )
581 t1 = tau*v1
582 v2 = v( 2 )
583 t2 = tau*v2
584 v3 = v( 3 )
585 t3 = tau*v3
586 v4 = v( 4 )
587 t4 = tau*v4
588 v5 = v( 5 )
589 t5 = tau*v5
590 v6 = v( 6 )
591 t6 = tau*v6
592 v7 = v( 7 )
593 t7 = tau*v7
594 v8 = v( 8 )
595 t8 = tau*v8
596 DO 360 j = 1, m
597 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
598 $ v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) +
599 $ v7*c( j, 7 ) + v8*c( j, 8 )
600 c( j, 1 ) = c( j, 1 ) - sum*t1
601 c( j, 2 ) = c( j, 2 ) - sum*t2
602 c( j, 3 ) = c( j, 3 ) - sum*t3
603 c( j, 4 ) = c( j, 4 ) - sum*t4
604 c( j, 5 ) = c( j, 5 ) - sum*t5
605 c( j, 6 ) = c( j, 6 ) - sum*t6
606 c( j, 7 ) = c( j, 7 ) - sum*t7
607 c( j, 8 ) = c( j, 8 ) - sum*t8
608 360 CONTINUE
609 GO TO 410
610 370 CONTINUE
611*
612* Special code for 9 x 9 Householder
613*
614 v1 = v( 1 )
615 t1 = tau*v1
616 v2 = v( 2 )
617 t2 = tau*v2
618 v3 = v( 3 )
619 t3 = tau*v3
620 v4 = v( 4 )
621 t4 = tau*v4
622 v5 = v( 5 )
623 t5 = tau*v5
624 v6 = v( 6 )
625 t6 = tau*v6
626 v7 = v( 7 )
627 t7 = tau*v7
628 v8 = v( 8 )
629 t8 = tau*v8
630 v9 = v( 9 )
631 t9 = tau*v9
632 DO 380 j = 1, m
633 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
634 $ v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) +
635 $ v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 )
636 c( j, 1 ) = c( j, 1 ) - sum*t1
637 c( j, 2 ) = c( j, 2 ) - sum*t2
638 c( j, 3 ) = c( j, 3 ) - sum*t3
639 c( j, 4 ) = c( j, 4 ) - sum*t4
640 c( j, 5 ) = c( j, 5 ) - sum*t5
641 c( j, 6 ) = c( j, 6 ) - sum*t6
642 c( j, 7 ) = c( j, 7 ) - sum*t7
643 c( j, 8 ) = c( j, 8 ) - sum*t8
644 c( j, 9 ) = c( j, 9 ) - sum*t9
645 380 CONTINUE
646 GO TO 410
647 390 CONTINUE
648*
649* Special code for 10 x 10 Householder
650*
651 v1 = v( 1 )
652 t1 = tau*v1
653 v2 = v( 2 )
654 t2 = tau*v2
655 v3 = v( 3 )
656 t3 = tau*v3
657 v4 = v( 4 )
658 t4 = tau*v4
659 v5 = v( 5 )
660 t5 = tau*v5
661 v6 = v( 6 )
662 t6 = tau*v6
663 v7 = v( 7 )
664 t7 = tau*v7
665 v8 = v( 8 )
666 t8 = tau*v8
667 v9 = v( 9 )
668 t9 = tau*v9
669 v10 = v( 10 )
670 t10 = tau*v10
671 DO 400 j = 1, m
672 sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +
673 $ v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) +
674 $ v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 ) +
675 $ v10*c( j, 10 )
676 c( j, 1 ) = c( j, 1 ) - sum*t1
677 c( j, 2 ) = c( j, 2 ) - sum*t2
678 c( j, 3 ) = c( j, 3 ) - sum*t3
679 c( j, 4 ) = c( j, 4 ) - sum*t4
680 c( j, 5 ) = c( j, 5 ) - sum*t5
681 c( j, 6 ) = c( j, 6 ) - sum*t6
682 c( j, 7 ) = c( j, 7 ) - sum*t7
683 c( j, 8 ) = c( j, 8 ) - sum*t8
684 c( j, 9 ) = c( j, 9 ) - sum*t9
685 c( j, 10 ) = c( j, 10 ) - sum*t10
686 400 CONTINUE
687 GO TO 410
688 END IF
689 410 CONTINUE
690 RETURN
691*
692* End of DLARFX
693*

◆ dlarfy()

subroutine dlarfy ( character uplo,
integer n,
double precision, dimension( * ) v,
integer incv,
double precision tau,
double precision, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) work )

DLARFY

Purpose:
!>
!> DLARFY applies an elementary reflector, or Householder matrix, H,
!> to an n x n symmetric matrix C, from both the left and the right.
!>
!> H is represented in the form
!>
!>    H = I - tau * v * v'
!>
!> where  tau  is a scalar and  v  is a vector.
!>
!> If  tau  is  zero, then  H  is taken to be the unit matrix.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix C is stored.
!>          = 'U':  Upper triangle
!>          = 'L':  Lower triangle
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix C.  N >= 0.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                  (1 + (N-1)*abs(INCV))
!>          The vector v as described above.
!>
[in]INCV
!>          INCV is INTEGER
!>          The increment between successive elements of v.  INCV must
!>          not be zero.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION
!>          The value tau as described above.
!>
[in,out]C
!>          C is DOUBLE PRECISION array, dimension (LDC, N)
!>          On entry, the matrix C.
!>          On exit, C is overwritten by H * C * H'.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max( 1, N ).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dlarfy.f.

108*
109* -- LAPACK test 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 CHARACTER UPLO
115 INTEGER INCV, LDC, N
116 DOUBLE PRECISION TAU
117* ..
118* .. Array Arguments ..
119 DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 DOUBLE PRECISION ONE, ZERO, HALF
126 parameter( one = 1.0d+0, zero = 0.0d+0, half = 0.5d+0 )
127* ..
128* .. Local Scalars ..
129 DOUBLE PRECISION ALPHA
130* ..
131* .. External Subroutines ..
132 EXTERNAL daxpy, dsymv, dsyr2
133* ..
134* .. External Functions ..
135 DOUBLE PRECISION DDOT
136 EXTERNAL ddot
137* ..
138* .. Executable Statements ..
139*
140 IF( tau.EQ.zero )
141 $ RETURN
142*
143* Form w:= C * v
144*
145 CALL dsymv( uplo, n, one, c, ldc, v, incv, zero, work, 1 )
146*
147 alpha = -half*tau*ddot( n, work, 1, v, incv )
148 CALL daxpy( n, alpha, v, incv, work, 1 )
149*
150* C := C - v * w' - w * v'
151*
152 CALL dsyr2( uplo, n, -tau, v, incv, work, 1, c, ldc )
153*
154 RETURN
155*
156* End of DLARFY
157*
dsymv
subroutine dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
DSYMV
Definition dsymv.f:152
dsyr2
subroutine dsyr2(uplo, n, alpha, x, incx, y, incy, a, lda)
DSYR2
Definition dsyr2.f:147

◆ dlargv()

subroutine dlargv ( integer n,
double precision, dimension( * ) x,
integer incx,
double precision, dimension( * ) y,
integer incy,
double precision, dimension( * ) c,
integer incc )

DLARGV generates a vector of plane rotations with real cosines and real sines.

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

Purpose:
!>
!> DLARGV generates a vector of real plane rotations, determined by
!> elements of the real vectors x and y. For i = 1,2,...,n
!>
!>    (  c(i)  s(i) ) ( x(i) ) = ( a(i) )
!>    ( -s(i)  c(i) ) ( y(i) ) = (   0  )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of plane rotations to be generated.
!>
[in,out]X
!>          X is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          On entry, the vector x.
!>          On exit, x(i) is overwritten by a(i), for i = 1,...,n.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCY)
!>          On entry, the vector y.
!>          On exit, the sines of the plane rotations.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between elements of Y. INCY > 0.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]INCC
!>          INCC is INTEGER
!>          The increment between elements of C. INCC > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dlargv.f.

104*
105* -- LAPACK auxiliary routine --
106* -- LAPACK is a software package provided by Univ. of Tennessee, --
107* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
108*
109* .. Scalar Arguments ..
110 INTEGER INCC, INCX, INCY, N
111* ..
112* .. Array Arguments ..
113 DOUBLE PRECISION C( * ), X( * ), Y( * )
114* ..
115*
116* =====================================================================
117*
118* .. Parameters ..
119 DOUBLE PRECISION ZERO, ONE
120 parameter( zero = 0.0d+0, one = 1.0d+0 )
121* ..
122* .. Local Scalars ..
123 INTEGER I, IC, IX, IY
124 DOUBLE PRECISION F, G, T, TT
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC abs, sqrt
128* ..
129* .. Executable Statements ..
130*
131 ix = 1
132 iy = 1
133 ic = 1
134 DO 10 i = 1, n
135 f = x( ix )
136 g = y( iy )
137 IF( g.EQ.zero ) THEN
138 c( ic ) = one
139 ELSE IF( f.EQ.zero ) THEN
140 c( ic ) = zero
141 y( iy ) = one
142 x( ix ) = g
143 ELSE IF( abs( f ).GT.abs( g ) ) THEN
144 t = g / f
145 tt = sqrt( one+t*t )
146 c( ic ) = one / tt
147 y( iy ) = t*c( ic )
148 x( ix ) = f*tt
149 ELSE
150 t = f / g
151 tt = sqrt( one+t*t )
152 y( iy ) = one / tt
153 c( ic ) = t*y( iy )
154 x( ix ) = g*tt
155 END IF
156 ic = ic + incc
157 iy = iy + incy
158 ix = ix + incx
159 10 CONTINUE
160 RETURN
161*
162* End of DLARGV
163*

◆ dlarrv()

subroutine dlarrv ( integer n,
double precision vl,
double precision vu,
double precision, dimension( * ) d,
double precision, dimension( * ) l,
double precision pivmin,
integer, dimension( * ) isplit,
integer m,
integer dol,
integer dou,
double precision minrgp,
double precision rtol1,
double precision rtol2,
double precision, dimension( * ) w,
double precision, dimension( * ) werr,
double precision, dimension( * ) wgap,
integer, dimension( * ) iblock,
integer, dimension( * ) indexw,
double precision, dimension( * ) gers,
double precision, dimension( ldz, * ) z,
integer ldz,
integer, dimension( * ) isuppz,
double precision, dimension( * ) work,
integer, dimension( * ) iwork,
integer info )

DLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT.

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

Purpose:
!>
!> DLARRV computes the eigenvectors of the tridiagonal matrix
!> T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T.
!> The input eigenvalues should have been computed by DLARRE.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in]VL
!>          VL is DOUBLE PRECISION
!>          Lower bound of the interval that contains the desired
!>          eigenvalues. VL < VU. Needed to compute gaps on the left or right
!>          end of the extremal eigenvalues in the desired RANGE.
!>
[in]VU
!>          VU is DOUBLE PRECISION
!>          Upper bound of the interval that contains the desired
!>          eigenvalues. VL < VU. 
!>          Note: VU is currently not used by this implementation of DLARRV, VU is
!>          passed to DLARRV because it could be used compute gaps on the right end
!>          of the extremal eigenvalues. However, with not much initial accuracy in
!>          LAMBDA and VU, the formula can lead to an overestimation of the right gap
!>          and thus to inadequately early RQI 'convergence'. This is currently
!>          prevented this by forcing a small right gap. And so it turns out that VU
!>          is currently not used by this implementation of DLARRV.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the N diagonal elements of the diagonal matrix D.
!>          On exit, D may be overwritten.
!>
[in,out]L
!>          L is DOUBLE PRECISION array, dimension (N)
!>          On entry, the (N-1) subdiagonal elements of the unit
!>          bidiagonal matrix L are in elements 1 to N-1 of L
!>          (if the matrix is not split.) At the end of each block
!>          is stored the corresponding shift as given by DLARRE.
!>          On exit, L is overwritten.
!>
[in]PIVMIN
!>          PIVMIN is DOUBLE PRECISION
!>          The minimum pivot allowed in the Sturm sequence.
!>
[in]ISPLIT
!>          ISPLIT is INTEGER array, dimension (N)
!>          The splitting points, at which T breaks up into blocks.
!>          The first block consists of rows/columns 1 to
!>          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
!>          through ISPLIT( 2 ), etc.
!>
[in]M
!>          M is INTEGER
!>          The total number of input eigenvalues.  0 <= M <= N.
!>
[in]DOL
!>          DOL is INTEGER
!>
[in]DOU
!>          DOU is INTEGER
!>          If the user wants to compute only selected eigenvectors from all
!>          the eigenvalues supplied, he can specify an index range DOL:DOU.
!>          Or else the setting DOL=1, DOU=M should be applied.
!>          Note that DOL and DOU refer to the order in which the eigenvalues
!>          are stored in W.
!>          If the user wants to compute only selected eigenpairs, then
!>          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
!>          computed eigenvectors. All other columns of Z are set to zero.
!>
[in]MINRGP
!>          MINRGP is DOUBLE PRECISION
!>
[in]RTOL1
!>          RTOL1 is DOUBLE PRECISION
!>
[in]RTOL2
!>          RTOL2 is DOUBLE PRECISION
!>           Parameters for bisection.
!>           An interval [LEFT,RIGHT] has converged if
!>           RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
!>
[in,out]W
!>          W is DOUBLE PRECISION array, dimension (N)
!>          The first M elements of W contain the APPROXIMATE eigenvalues for
!>          which eigenvectors are to be computed.  The eigenvalues
!>          should be grouped by split-off block and ordered from
!>          smallest to largest within the block ( The output array
!>          W from DLARRE is expected here ). Furthermore, they are with
!>          respect to the shift of the corresponding root representation
!>          for their block. On exit, W holds the eigenvalues of the
!>          UNshifted matrix.
!>
[in,out]WERR
!>          WERR is DOUBLE PRECISION array, dimension (N)
!>          The first M elements contain the semiwidth of the uncertainty
!>          interval of the corresponding eigenvalue in W
!>
[in,out]WGAP
!>          WGAP is DOUBLE PRECISION array, dimension (N)
!>          The separation from the right neighbor eigenvalue in W.
!>
[in]IBLOCK
!>          IBLOCK is INTEGER array, dimension (N)
!>          The indices of the blocks (submatrices) associated with the
!>          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
!>          W(i) belongs to the first block from the top, =2 if W(i)
!>          belongs to the second block, etc.
!>
[in]INDEXW
!>          INDEXW is INTEGER array, dimension (N)
!>          The indices of the eigenvalues within each block (submatrix);
!>          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
!>          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
!>
[in]GERS
!>          GERS is DOUBLE PRECISION array, dimension (2*N)
!>          The N Gerschgorin intervals (the i-th Gerschgorin interval
!>          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
!>          be computed from the original UNshifted matrix.
!>
[out]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
!>          If INFO = 0, the first M columns of Z contain the
!>          orthonormal eigenvectors of the matrix T
!>          corresponding to the input eigenvalues, with the i-th
!>          column of Z holding the eigenvector associated with W(i).
!>          Note: the user must ensure that at least max(1,M) columns are
!>          supplied in the array Z.
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', LDZ >= max(1,N).
!>
[out]ISUPPZ
!>          ISUPPZ is INTEGER array, dimension ( 2*max(1,M) )
!>          The support of the eigenvectors in Z, i.e., the indices
!>          indicating the nonzero elements in Z. The I-th eigenvector
!>          is nonzero only in elements ISUPPZ( 2*I-1 ) through
!>          ISUPPZ( 2*I ).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (12*N)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (7*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>
!>          > 0:  A problem occurred in DLARRV.
!>          < 0:  One of the called subroutines signaled an internal problem.
!>                Needs inspection of the corresponding parameter IINFO
!>                for further information.
!>
!>          =-1:  Problem in DLARRB when refining a child's eigenvalues.
!>          =-2:  Problem in DLARRF when computing the RRR of a child.
!>                When a child is inside a tight cluster, it can be difficult
!>                to find an RRR. A partial remedy from the user's point of
!>                view is to make the parameter MINRGP smaller and recompile.
!>                However, as the orthogonality of the computed vectors is
!>                proportional to 1/MINRGP, the user should be aware that
!>                he might be trading in precision when he decreases MINRGP.
!>          =-3:  Problem in DLARRB when refining a single eigenvalue
!>                after the Rayleigh correction was rejected.
!>          = 5:  The Rayleigh Quotient Iteration failed to converge to
!>                full accuracy in MAXITR steps.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Beresford Parlett, University of California, Berkeley, USA
Jim Demmel, University of California, Berkeley, USA
Inderjit Dhillon, University of Texas, Austin, USA
Osni Marques, LBNL/NERSC, USA
Christof Voemel, University of California, Berkeley, USA

Definition at line 287 of file dlarrv.f.

292*
293* -- LAPACK auxiliary routine --
294* -- LAPACK is a software package provided by Univ. of Tennessee, --
295* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
296*
297* .. Scalar Arguments ..
298 INTEGER DOL, DOU, INFO, LDZ, M, N
299 DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
300* ..
301* .. Array Arguments ..
302 INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
303 $ ISUPPZ( * ), IWORK( * )
304 DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
305 $ WGAP( * ), WORK( * )
306 DOUBLE PRECISION Z( LDZ, * )
307* ..
308*
309* =====================================================================
310*
311* .. Parameters ..
312 INTEGER MAXITR
313 parameter( maxitr = 10 )
314 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
315 parameter( zero = 0.0d0, one = 1.0d0,
316 $ two = 2.0d0, three = 3.0d0,
317 $ four = 4.0d0, half = 0.5d0)
318* ..
319* .. Local Scalars ..
320 LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
321 INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
322 $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
323 $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
324 $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
325 $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
326 $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
327 $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
328 $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
329 $ ZUSEDW
330 DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
331 $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
332 $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
333 $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
334* ..
335* .. External Functions ..
336 DOUBLE PRECISION DLAMCH
337 EXTERNAL dlamch
338* ..
339* .. External Subroutines ..
340 EXTERNAL dcopy, dlar1v, dlarrb, dlarrf, dlaset,
341 $ dscal
342* ..
343* .. Intrinsic Functions ..
344 INTRINSIC abs, dble, max, min
345* ..
346* .. Executable Statements ..
347* ..
348
349 info = 0
350*
351* Quick return if possible
352*
353 IF( (n.LE.0).OR.(m.LE.0) ) THEN
354 RETURN
355 END IF
356*
357* The first N entries of WORK are reserved for the eigenvalues
358 indld = n+1
359 indlld= 2*n+1
360 indwrk= 3*n+1
361 minwsize = 12 * n
362
363 DO 5 i= 1,minwsize
364 work( i ) = zero
365 5 CONTINUE
366
367* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
368* factorization used to compute the FP vector
369 iindr = 0
370* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
371* layer and the one above.
372 iindc1 = n
373 iindc2 = 2*n
374 iindwk = 3*n + 1
375
376 miniwsize = 7 * n
377 DO 10 i= 1,miniwsize
378 iwork( i ) = 0
379 10 CONTINUE
380
381 zusedl = 1
382 IF(dol.GT.1) THEN
383* Set lower bound for use of Z
384 zusedl = dol-1
385 ENDIF
386 zusedu = m
387 IF(dou.LT.m) THEN
388* Set lower bound for use of Z
389 zusedu = dou+1
390 ENDIF
391* The width of the part of Z that is used
392 zusedw = zusedu - zusedl + 1
393
394
395 CALL dlaset( 'Full', n, zusedw, zero, zero,
396 $ z(1,zusedl), ldz )
397
398 eps = dlamch( 'Precision' )
399 rqtol = two * eps
400*
401* Set expert flags for standard code.
402 tryrqc = .true.
403
404 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
405 ELSE
406* Only selected eigenpairs are computed. Since the other evalues
407* are not refined by RQ iteration, bisection has to compute to full
408* accuracy.
409 rtol1 = four * eps
410 rtol2 = four * eps
411 ENDIF
412
413* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
414* desired eigenvalues. The support of the nonzero eigenvector
415* entries is contained in the interval IBEGIN:IEND.
416* Remark that if k eigenpairs are desired, then the eigenvectors
417* are stored in k contiguous columns of Z.
418
419* DONE is the number of eigenvectors already computed
420 done = 0
421 ibegin = 1
422 wbegin = 1
423 DO 170 jblk = 1, iblock( m )
424 iend = isplit( jblk )
425 sigma = l( iend )
426* Find the eigenvectors of the submatrix indexed IBEGIN
427* through IEND.
428 wend = wbegin - 1
429 15 CONTINUE
430 IF( wend.LT.m ) THEN
431 IF( iblock( wend+1 ).EQ.jblk ) THEN
432 wend = wend + 1
433 GO TO 15
434 END IF
435 END IF
436 IF( wend.LT.wbegin ) THEN
437 ibegin = iend + 1
438 GO TO 170
439 ELSEIF( (wend.LT.dol).OR.(wbegin.GT.dou) ) THEN
440 ibegin = iend + 1
441 wbegin = wend + 1
442 GO TO 170
443 END IF
444
445* Find local spectral diameter of the block
446 gl = gers( 2*ibegin-1 )
447 gu = gers( 2*ibegin )
448 DO 20 i = ibegin+1 , iend
449 gl = min( gers( 2*i-1 ), gl )
450 gu = max( gers( 2*i ), gu )
451 20 CONTINUE
452 spdiam = gu - gl
453
454* OLDIEN is the last index of the previous block
455 oldien = ibegin - 1
456* Calculate the size of the current block
457 in = iend - ibegin + 1
458* The number of eigenvalues in the current block
459 im = wend - wbegin + 1
460
461* This is for a 1x1 block
462 IF( ibegin.EQ.iend ) THEN
463 done = done+1
464 z( ibegin, wbegin ) = one
465 isuppz( 2*wbegin-1 ) = ibegin
466 isuppz( 2*wbegin ) = ibegin
467 w( wbegin ) = w( wbegin ) + sigma
468 work( wbegin ) = w( wbegin )
469 ibegin = iend + 1
470 wbegin = wbegin + 1
471 GO TO 170
472 END IF
473
474* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
475* Note that these can be approximations, in this case, the corresp.
476* entries of WERR give the size of the uncertainty interval.
477* The eigenvalue approximations will be refined when necessary as
478* high relative accuracy is required for the computation of the
479* corresponding eigenvectors.
480 CALL dcopy( im, w( wbegin ), 1,
481 $ work( wbegin ), 1 )
482
483* We store in W the eigenvalue approximations w.r.t. the original
484* matrix T.
485 DO 30 i=1,im
486 w(wbegin+i-1) = w(wbegin+i-1)+sigma
487 30 CONTINUE
488
489
490* NDEPTH is the current depth of the representation tree
491 ndepth = 0
492* PARITY is either 1 or 0
493 parity = 1
494* NCLUS is the number of clusters for the next level of the
495* representation tree, we start with NCLUS = 1 for the root
496 nclus = 1
497 iwork( iindc1+1 ) = 1
498 iwork( iindc1+2 ) = im
499
500* IDONE is the number of eigenvectors already computed in the current
501* block
502 idone = 0
503* loop while( IDONE.LT.IM )
504* generate the representation tree for the current block and
505* compute the eigenvectors
506 40 CONTINUE
507 IF( idone.LT.im ) THEN
508* This is a crude protection against infinitely deep trees
509 IF( ndepth.GT.m ) THEN
510 info = -2
511 RETURN
512 ENDIF
513* breadth first processing of the current level of the representation
514* tree: OLDNCL = number of clusters on current level
515 oldncl = nclus
516* reset NCLUS to count the number of child clusters
517 nclus = 0
518*
519 parity = 1 - parity
520 IF( parity.EQ.0 ) THEN
521 oldcls = iindc1
522 newcls = iindc2
523 ELSE
524 oldcls = iindc2
525 newcls = iindc1
526 END IF
527* Process the clusters on the current level
528 DO 150 i = 1, oldncl
529 j = oldcls + 2*i
530* OLDFST, OLDLST = first, last index of current cluster.
531* cluster indices start with 1 and are relative
532* to WBEGIN when accessing W, WGAP, WERR, Z
533 oldfst = iwork( j-1 )
534 oldlst = iwork( j )
535 IF( ndepth.GT.0 ) THEN
536* Retrieve relatively robust representation (RRR) of cluster
537* that has been computed at the previous level
538* The RRR is stored in Z and overwritten once the eigenvectors
539* have been computed or when the cluster is refined
540
541 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
542* Get representation from location of the leftmost evalue
543* of the cluster
544 j = wbegin + oldfst - 1
545 ELSE
546 IF(wbegin+oldfst-1.LT.dol) THEN
547* Get representation from the left end of Z array
548 j = dol - 1
549 ELSEIF(wbegin+oldfst-1.GT.dou) THEN
550* Get representation from the right end of Z array
551 j = dou
552 ELSE
553 j = wbegin + oldfst - 1
554 ENDIF
555 ENDIF
556 CALL dcopy( in, z( ibegin, j ), 1, d( ibegin ), 1 )
557 CALL dcopy( in-1, z( ibegin, j+1 ), 1, l( ibegin ),
558 $ 1 )
559 sigma = z( iend, j+1 )
560
561* Set the corresponding entries in Z to zero
562 CALL dlaset( 'Full', in, 2, zero, zero,
563 $ z( ibegin, j), ldz )
564 END IF
565
566* Compute DL and DLL of current RRR
567 DO 50 j = ibegin, iend-1
568 tmp = d( j )*l( j )
569 work( indld-1+j ) = tmp
570 work( indlld-1+j ) = tmp*l( j )
571 50 CONTINUE
572
573 IF( ndepth.GT.0 ) THEN
574* P and Q are index of the first and last eigenvalue to compute
575* within the current block
576 p = indexw( wbegin-1+oldfst )
577 q = indexw( wbegin-1+oldlst )
578* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
579* through the Q-OFFSET elements of these arrays are to be used.
580* OFFSET = P-OLDFST
581 offset = indexw( wbegin ) - 1
582* perform limited bisection (if necessary) to get approximate
583* eigenvalues to the precision needed.
584 CALL dlarrb( in, d( ibegin ),
585 $ work(indlld+ibegin-1),
586 $ p, q, rtol1, rtol2, offset,
587 $ work(wbegin),wgap(wbegin),werr(wbegin),
588 $ work( indwrk ), iwork( iindwk ),
589 $ pivmin, spdiam, in, iinfo )
590 IF( iinfo.NE.0 ) THEN
591 info = -1
592 RETURN
593 ENDIF
594* We also recompute the extremal gaps. W holds all eigenvalues
595* of the unshifted matrix and must be used for computation
596* of WGAP, the entries of WORK might stem from RRRs with
597* different shifts. The gaps from WBEGIN-1+OLDFST to
598* WBEGIN-1+OLDLST are correctly computed in DLARRB.
599* However, we only allow the gaps to become greater since
600* this is what should happen when we decrease WERR
601 IF( oldfst.GT.1) THEN
602 wgap( wbegin+oldfst-2 ) =
603 $ max(wgap(wbegin+oldfst-2),
604 $ w(wbegin+oldfst-1)-werr(wbegin+oldfst-1)
605 $ - w(wbegin+oldfst-2)-werr(wbegin+oldfst-2) )
606 ENDIF
607 IF( wbegin + oldlst -1 .LT. wend ) THEN
608 wgap( wbegin+oldlst-1 ) =
609 $ max(wgap(wbegin+oldlst-1),
610 $ w(wbegin+oldlst)-werr(wbegin+oldlst)
611 $ - w(wbegin+oldlst-1)-werr(wbegin+oldlst-1) )
612 ENDIF
613* Each time the eigenvalues in WORK get refined, we store
614* the newly found approximation with all shifts applied in W
615 DO 53 j=oldfst,oldlst
616 w(wbegin+j-1) = work(wbegin+j-1)+sigma
617 53 CONTINUE
618 END IF
619
620* Process the current node.
621 newfst = oldfst
622 DO 140 j = oldfst, oldlst
623 IF( j.EQ.oldlst ) THEN
624* we are at the right end of the cluster, this is also the
625* boundary of the child cluster
626 newlst = j
627 ELSE IF ( wgap( wbegin + j -1).GE.
628 $ minrgp* abs( work(wbegin + j -1) ) ) THEN
629* the right relative gap is big enough, the child cluster
630* (NEWFST,..,NEWLST) is well separated from the following
631 newlst = j
632 ELSE
633* inside a child cluster, the relative gap is not
634* big enough.
635 GOTO 140
636 END IF
637
638* Compute size of child cluster found
639 newsiz = newlst - newfst + 1
640
641* NEWFTT is the place in Z where the new RRR or the computed
642* eigenvector is to be stored
643 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
644* Store representation at location of the leftmost evalue
645* of the cluster
646 newftt = wbegin + newfst - 1
647 ELSE
648 IF(wbegin+newfst-1.LT.dol) THEN
649* Store representation at the left end of Z array
650 newftt = dol - 1
651 ELSEIF(wbegin+newfst-1.GT.dou) THEN
652* Store representation at the right end of Z array
653 newftt = dou
654 ELSE
655 newftt = wbegin + newfst - 1
656 ENDIF
657 ENDIF
658
659 IF( newsiz.GT.1) THEN
660*
661* Current child is not a singleton but a cluster.
662* Compute and store new representation of child.
663*
664*
665* Compute left and right cluster gap.
666*
667* LGAP and RGAP are not computed from WORK because
668* the eigenvalue approximations may stem from RRRs
669* different shifts. However, W hold all eigenvalues
670* of the unshifted matrix. Still, the entries in WGAP
671* have to be computed from WORK since the entries
672* in W might be of the same order so that gaps are not
673* exhibited correctly for very close eigenvalues.
674 IF( newfst.EQ.1 ) THEN
675 lgap = max( zero,
676 $ w(wbegin)-werr(wbegin) - vl )
677 ELSE
678 lgap = wgap( wbegin+newfst-2 )
679 ENDIF
680 rgap = wgap( wbegin+newlst-1 )
681*
682* Compute left- and rightmost eigenvalue of child
683* to high precision in order to shift as close
684* as possible and obtain as large relative gaps
685* as possible
686*
687 DO 55 k =1,2
688 IF(k.EQ.1) THEN
689 p = indexw( wbegin-1+newfst )
690 ELSE
691 p = indexw( wbegin-1+newlst )
692 ENDIF
693 offset = indexw( wbegin ) - 1
694 CALL dlarrb( in, d(ibegin),
695 $ work( indlld+ibegin-1 ),p,p,
696 $ rqtol, rqtol, offset,
697 $ work(wbegin),wgap(wbegin),
698 $ werr(wbegin),work( indwrk ),
699 $ iwork( iindwk ), pivmin, spdiam,
700 $ in, iinfo )
701 55 CONTINUE
702*
703 IF((wbegin+newlst-1.LT.dol).OR.
704 $ (wbegin+newfst-1.GT.dou)) THEN
705* if the cluster contains no desired eigenvalues
706* skip the computation of that branch of the rep. tree
707*
708* We could skip before the refinement of the extremal
709* eigenvalues of the child, but then the representation
710* tree could be different from the one when nothing is
711* skipped. For this reason we skip at this place.
712 idone = idone + newlst - newfst + 1
713 GOTO 139
714 ENDIF
715*
716* Compute RRR of child cluster.
717* Note that the new RRR is stored in Z
718*
719* DLARRF needs LWORK = 2*N
720 CALL dlarrf( in, d( ibegin ), l( ibegin ),
721 $ work(indld+ibegin-1),
722 $ newfst, newlst, work(wbegin),
723 $ wgap(wbegin), werr(wbegin),
724 $ spdiam, lgap, rgap, pivmin, tau,
725 $ z(ibegin, newftt),z(ibegin, newftt+1),
726 $ work( indwrk ), iinfo )
727 IF( iinfo.EQ.0 ) THEN
728* a new RRR for the cluster was found by DLARRF
729* update shift and store it
730 ssigma = sigma + tau
731 z( iend, newftt+1 ) = ssigma
732* WORK() are the midpoints and WERR() the semi-width
733* Note that the entries in W are unchanged.
734 DO 116 k = newfst, newlst
735 fudge =
736 $ three*eps*abs(work(wbegin+k-1))
737 work( wbegin + k - 1 ) =
738 $ work( wbegin + k - 1) - tau
739 fudge = fudge +
740 $ four*eps*abs(work(wbegin+k-1))
741* Fudge errors
742 werr( wbegin + k - 1 ) =
743 $ werr( wbegin + k - 1 ) + fudge
744* Gaps are not fudged. Provided that WERR is small
745* when eigenvalues are close, a zero gap indicates
746* that a new representation is needed for resolving
747* the cluster. A fudge could lead to a wrong decision
748* of judging eigenvalues 'separated' which in
749* reality are not. This could have a negative impact
750* on the orthogonality of the computed eigenvectors.
751 116 CONTINUE
752
753 nclus = nclus + 1
754 k = newcls + 2*nclus
755 iwork( k-1 ) = newfst
756 iwork( k ) = newlst
757 ELSE
758 info = -2
759 RETURN
760 ENDIF
761 ELSE
762*
763* Compute eigenvector of singleton
764*
765 iter = 0
766*
767 tol = four * log(dble(in)) * eps
768*
769 k = newfst
770 windex = wbegin + k - 1
771 windmn = max(windex - 1,1)
772 windpl = min(windex + 1,m)
773 lambda = work( windex )
774 done = done + 1
775* Check if eigenvector computation is to be skipped
776 IF((windex.LT.dol).OR.
777 $ (windex.GT.dou)) THEN
778 eskip = .true.
779 GOTO 125
780 ELSE
781 eskip = .false.
782 ENDIF
783 left = work( windex ) - werr( windex )
784 right = work( windex ) + werr( windex )
785 indeig = indexw( windex )
786* Note that since we compute the eigenpairs for a child,
787* all eigenvalue approximations are w.r.t the same shift.
788* In this case, the entries in WORK should be used for
789* computing the gaps since they exhibit even very small
790* differences in the eigenvalues, as opposed to the
791* entries in W which might "look" the same.
792
793 IF( k .EQ. 1) THEN
794* In the case RANGE='I' and with not much initial
795* accuracy in LAMBDA and VL, the formula
796* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
797* can lead to an overestimation of the left gap and
798* thus to inadequately early RQI 'convergence'.
799* Prevent this by forcing a small left gap.
800 lgap = eps*max(abs(left),abs(right))
801 ELSE
802 lgap = wgap(windmn)
803 ENDIF
804 IF( k .EQ. im) THEN
805* In the case RANGE='I' and with not much initial
806* accuracy in LAMBDA and VU, the formula
807* can lead to an overestimation of the right gap and
808* thus to inadequately early RQI 'convergence'.
809* Prevent this by forcing a small right gap.
810 rgap = eps*max(abs(left),abs(right))
811 ELSE
812 rgap = wgap(windex)
813 ENDIF
814 gap = min( lgap, rgap )
815 IF(( k .EQ. 1).OR.(k .EQ. im)) THEN
816* The eigenvector support can become wrong
817* because significant entries could be cut off due to a
818* large GAPTOL parameter in LAR1V. Prevent this.
819 gaptol = zero
820 ELSE
821 gaptol = gap * eps
822 ENDIF
823 isupmn = in
824 isupmx = 1
825* Update WGAP so that it holds the minimum gap
826* to the left or the right. This is crucial in the
827* case where bisection is used to ensure that the
828* eigenvalue is refined up to the required precision.
829* The correct value is restored afterwards.
830 savgap = wgap(windex)
831 wgap(windex) = gap
832* We want to use the Rayleigh Quotient Correction
833* as often as possible since it converges quadratically
834* when we are close enough to the desired eigenvalue.
835* However, the Rayleigh Quotient can have the wrong sign
836* and lead us away from the desired eigenvalue. In this
837* case, the best we can do is to use bisection.
838 usedbs = .false.
839 usedrq = .false.
840* Bisection is initially turned off unless it is forced
841 needbs = .NOT.tryrqc
842 120 CONTINUE
843* Check if bisection should be used to refine eigenvalue
844 IF(needbs) THEN
845* Take the bisection as new iterate
846 usedbs = .true.
847 itmp1 = iwork( iindr+windex )
848 offset = indexw( wbegin ) - 1
849 CALL dlarrb( in, d(ibegin),
850 $ work(indlld+ibegin-1),indeig,indeig,
851 $ zero, two*eps, offset,
852 $ work(wbegin),wgap(wbegin),
853 $ werr(wbegin),work( indwrk ),
854 $ iwork( iindwk ), pivmin, spdiam,
855 $ itmp1, iinfo )
856 IF( iinfo.NE.0 ) THEN
857 info = -3
858 RETURN
859 ENDIF
860 lambda = work( windex )
861* Reset twist index from inaccurate LAMBDA to
862* force computation of true MINGMA
863 iwork( iindr+windex ) = 0
864 ENDIF
865* Given LAMBDA, compute the eigenvector.
866 CALL dlar1v( in, 1, in, lambda, d( ibegin ),
867 $ l( ibegin ), work(indld+ibegin-1),
868 $ work(indlld+ibegin-1),
869 $ pivmin, gaptol, z( ibegin, windex ),
870 $ .NOT.usedbs, negcnt, ztz, mingma,
871 $ iwork( iindr+windex ), isuppz( 2*windex-1 ),
872 $ nrminv, resid, rqcorr, work( indwrk ) )
873 IF(iter .EQ. 0) THEN
874 bstres = resid
875 bstw = lambda
876 ELSEIF(resid.LT.bstres) THEN
877 bstres = resid
878 bstw = lambda
879 ENDIF
880 isupmn = min(isupmn,isuppz( 2*windex-1 ))
881 isupmx = max(isupmx,isuppz( 2*windex ))
882 iter = iter + 1
883
884* sin alpha <= |resid|/gap
885* Note that both the residual and the gap are
886* proportional to the matrix, so ||T|| doesn't play
887* a role in the quotient
888
889*
890* Convergence test for Rayleigh-Quotient iteration
891* (omitted when Bisection has been used)
892*
893 IF( resid.GT.tol*gap .AND. abs( rqcorr ).GT.
894 $ rqtol*abs( lambda ) .AND. .NOT. usedbs)
895 $ THEN
896* We need to check that the RQCORR update doesn't
897* move the eigenvalue away from the desired one and
898* towards a neighbor. -> protection with bisection
899 IF(indeig.LE.negcnt) THEN
900* The wanted eigenvalue lies to the left
901 sgndef = -one
902 ELSE
903* The wanted eigenvalue lies to the right
904 sgndef = one
905 ENDIF
906* We only use the RQCORR if it improves the
907* the iterate reasonably.
908 IF( ( rqcorr*sgndef.GE.zero )
909 $ .AND.( lambda + rqcorr.LE. right)
910 $ .AND.( lambda + rqcorr.GE. left)
911 $ ) THEN
912 usedrq = .true.
913* Store new midpoint of bisection interval in WORK
914 IF(sgndef.EQ.one) THEN
915* The current LAMBDA is on the left of the true
916* eigenvalue
917 left = lambda
918* We prefer to assume that the error estimate
919* is correct. We could make the interval not
920* as a bracket but to be modified if the RQCORR
921* chooses to. In this case, the RIGHT side should
922* be modified as follows:
923* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
924 ELSE
925* The current LAMBDA is on the right of the true
926* eigenvalue
927 right = lambda
928* See comment about assuming the error estimate is
929* correct above.
930* LEFT = MIN(LEFT, LAMBDA + RQCORR)
931 ENDIF
932 work( windex ) =
933 $ half * (right + left)
934* Take RQCORR since it has the correct sign and
935* improves the iterate reasonably
936 lambda = lambda + rqcorr
937* Update width of error interval
938 werr( windex ) =
939 $ half * (right-left)
940 ELSE
941 needbs = .true.
942 ENDIF
943 IF(right-left.LT.rqtol*abs(lambda)) THEN
944* The eigenvalue is computed to bisection accuracy
945* compute eigenvector and stop
946 usedbs = .true.
947 GOTO 120
948 ELSEIF( iter.LT.maxitr ) THEN
949 GOTO 120
950 ELSEIF( iter.EQ.maxitr ) THEN
951 needbs = .true.
952 GOTO 120
953 ELSE
954 info = 5
955 RETURN
956 END IF
957 ELSE
958 stp2ii = .false.
959 IF(usedrq .AND. usedbs .AND.
960 $ bstres.LE.resid) THEN
961 lambda = bstw
962 stp2ii = .true.
963 ENDIF
964 IF (stp2ii) THEN
965* improve error angle by second step
966 CALL dlar1v( in, 1, in, lambda,
967 $ d( ibegin ), l( ibegin ),
968 $ work(indld+ibegin-1),
969 $ work(indlld+ibegin-1),
970 $ pivmin, gaptol, z( ibegin, windex ),
971 $ .NOT.usedbs, negcnt, ztz, mingma,
972 $ iwork( iindr+windex ),
973 $ isuppz( 2*windex-1 ),
974 $ nrminv, resid, rqcorr, work( indwrk ) )
975 ENDIF
976 work( windex ) = lambda
977 END IF
978*
979* Compute FP-vector support w.r.t. whole matrix
980*
981 isuppz( 2*windex-1 ) = isuppz( 2*windex-1 )+oldien
982 isuppz( 2*windex ) = isuppz( 2*windex )+oldien
983 zfrom = isuppz( 2*windex-1 )
984 zto = isuppz( 2*windex )
985 isupmn = isupmn + oldien
986 isupmx = isupmx + oldien
987* Ensure vector is ok if support in the RQI has changed
988 IF(isupmn.LT.zfrom) THEN
989 DO 122 ii = isupmn,zfrom-1
990 z( ii, windex ) = zero
991 122 CONTINUE
992 ENDIF
993 IF(isupmx.GT.zto) THEN
994 DO 123 ii = zto+1,isupmx
995 z( ii, windex ) = zero
996 123 CONTINUE
997 ENDIF
998 CALL dscal( zto-zfrom+1, nrminv,
999 $ z( zfrom, windex ), 1 )
1000 125 CONTINUE
1001* Update W
1002 w( windex ) = lambda+sigma
1003* Recompute the gaps on the left and right
1004* But only allow them to become larger and not
1005* smaller (which can only happen through "bad"
1006* cancellation and doesn't reflect the theory
1007* where the initial gaps are underestimated due
1008* to WERR being too crude.)
1009 IF(.NOT.eskip) THEN
1010 IF( k.GT.1) THEN
1011 wgap( windmn ) = max( wgap(windmn),
1012 $ w(windex)-werr(windex)
1013 $ - w(windmn)-werr(windmn) )
1014 ENDIF
1015 IF( windex.LT.wend ) THEN
1016 wgap( windex ) = max( savgap,
1017 $ w( windpl )-werr( windpl )
1018 $ - w( windex )-werr( windex) )
1019 ENDIF
1020 ENDIF
1021 idone = idone + 1
1022 ENDIF
1023* here ends the code for the current child
1024*
1025 139 CONTINUE
1026* Proceed to any remaining child nodes
1027 newfst = j + 1
1028 140 CONTINUE
1029 150 CONTINUE
1030 ndepth = ndepth + 1
1031 GO TO 40
1032 END IF
1033 ibegin = iend + 1
1034 wbegin = wend + 1
1035 170 CONTINUE
1036*
1037
1038 RETURN
1039*
1040* End of DLARRV
1041*
dlarrb
subroutine dlarrb(n, d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, work, iwork, pivmin, spdiam, twist, info)
DLARRB provides limited bisection to locate eigenvalues for more accuracy.
Definition dlarrb.f:196
dlarrf
subroutine dlarrf(n, d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, sigma, dplus, lplus, work, info)
DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
Definition dlarrf.f:193
dlar1v
subroutine dlar1v(n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
DLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...
Definition dlar1v.f:230

◆ dlartv()

subroutine dlartv ( integer n,
double precision, dimension( * ) x,
integer incx,
double precision, dimension( * ) y,
integer incy,
double precision, dimension( * ) c,
double precision, dimension( * ) s,
integer incc )

DLARTV applies a vector of plane rotations with real cosines and real sines to the elements of a pair of vectors.

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

Purpose:
!>
!> DLARTV applies a vector of real plane rotations to elements of the
!> real vectors x and y. For i = 1,2,...,n
!>
!>    ( x(i) ) := (  c(i)  s(i) ) ( x(i) )
!>    ( y(i) )    ( -s(i)  c(i) ) ( y(i) )
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of plane rotations to be applied.
!>
[in,out]X
!>          X is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector x.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!>
[in,out]Y
!>          Y is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCY)
!>          The vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between elements of Y. INCY > 0.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The sines of the plane rotations.
!>
[in]INCC
!>          INCC is INTEGER
!>          The increment between elements of C and S. INCC > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dlartv.f.

108*
109* -- LAPACK auxiliary 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 INCC, INCX, INCY, N
115* ..
116* .. Array Arguments ..
117 DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * )
118* ..
119*
120* =====================================================================
121*
122* .. Local Scalars ..
123 INTEGER I, IC, IX, IY
124 DOUBLE PRECISION XI, YI
125* ..
126* .. Executable Statements ..
127*
128 ix = 1
129 iy = 1
130 ic = 1
131 DO 10 i = 1, n
132 xi = x( ix )
133 yi = y( iy )
134 x( ix ) = c( ic )*xi + s( ic )*yi
135 y( iy ) = c( ic )*yi - s( ic )*xi
136 ix = ix + incx
137 iy = iy + incy
138 ic = ic + incc
139 10 CONTINUE
140 RETURN
141*
142* End of DLARTV
143*

◆ dlaswp()

subroutine dlaswp ( integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer k1,
integer k2,
integer, dimension( * ) ipiv,
integer incx )

DLASWP performs a series of row interchanges on a general rectangular matrix.

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

Purpose:
!>
!> DLASWP performs a series of row interchanges on the matrix A.
!> One row interchange is initiated for each of rows K1 through K2 of A.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the matrix of column dimension N to which the row
!>          interchanges will be applied.
!>          On exit, the permuted matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]K1
!>          K1 is INTEGER
!>          The first element of IPIV for which a row interchange will
!>          be done.
!>
[in]K2
!>          K2 is INTEGER
!>          (K2-K1+1) is the number of elements of IPIV for which a row
!>          interchange will be done.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
!>          The vector of pivot indices. Only the elements in positions
!>          K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
!>          IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
!>          interchanged.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between successive values of IPIV. If INCX
!>          is negative, the pivots are applied in reverse order.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Modified by
!>   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!>

Definition at line 114 of file dlaswp.f.

115*
116* -- LAPACK auxiliary routine --
117* -- LAPACK is a software package provided by Univ. of Tennessee, --
118* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
119*
120* .. Scalar Arguments ..
121 INTEGER INCX, K1, K2, LDA, N
122* ..
123* .. Array Arguments ..
124 INTEGER IPIV( * )
125 DOUBLE PRECISION A( LDA, * )
126* ..
127*
128* =====================================================================
129*
130* .. Local Scalars ..
131 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
132 DOUBLE PRECISION TEMP
133* ..
134* .. Executable Statements ..
135*
136* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
137* K1 through K2.
138*
139 IF( incx.GT.0 ) THEN
140 ix0 = k1
141 i1 = k1
142 i2 = k2
143 inc = 1
144 ELSE IF( incx.LT.0 ) THEN
145 ix0 = k1 + ( k1-k2 )*incx
146 i1 = k2
147 i2 = k1
148 inc = -1
149 ELSE
150 RETURN
151 END IF
152*
153 n32 = ( n / 32 )*32
154 IF( n32.NE.0 ) THEN
155 DO 30 j = 1, n32, 32
156 ix = ix0
157 DO 20 i = i1, i2, inc
158 ip = ipiv( ix )
159 IF( ip.NE.i ) THEN
160 DO 10 k = j, j + 31
161 temp = a( i, k )
162 a( i, k ) = a( ip, k )
163 a( ip, k ) = temp
164 10 CONTINUE
165 END IF
166 ix = ix + incx
167 20 CONTINUE
168 30 CONTINUE
169 END IF
170 IF( n32.NE.n ) THEN
171 n32 = n32 + 1
172 ix = ix0
173 DO 50 i = i1, i2, inc
174 ip = ipiv( ix )
175 IF( ip.NE.i ) THEN
176 DO 40 k = n32, n
177 temp = a( i, k )
178 a( i, k ) = a( ip, k )
179 a( ip, k ) = temp
180 40 CONTINUE
181 END IF
182 ix = ix + incx
183 50 CONTINUE
184 END IF
185*
186 RETURN
187*
188* End of DLASWP
189*

◆ dlat2s()

subroutine dlat2s ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
real, dimension( ldsa, * ) sa,
integer ldsa,
integer info )

DLAT2S converts a double-precision triangular matrix to a single-precision triangular matrix.

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

Purpose:
!>
!> DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE
!> PRECISION triangular matrix, A.
!>
!> RMAX is the overflow for the SINGLE PRECISION arithmetic
!> DLAS2S checks that all the entries of A are between -RMAX and
!> RMAX. If not the conversion is aborted and a flag is raised.
!>
!> This is an auxiliary routine so there is no argument checking.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          = 'U':  A is upper triangular;
!>          = 'L':  A is lower triangular.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the N-by-N triangular coefficient matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]SA
!>          SA is REAL array, dimension (LDSA,N)
!>          Only the UPLO part of SA is referenced.  On exit, if INFO=0,
!>          the N-by-N coefficient matrix SA; if INFO>0, the content of
!>          the UPLO part of SA is unspecified.
!>
[in]LDSA
!>          LDSA is INTEGER
!>          The leading dimension of the array SA.  LDSA >= max(1,M).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          = 1:  an entry of the matrix A is greater than the SINGLE
!>                PRECISION overflow threshold, in this case, the content
!>                of the UPLO part of SA in exit is unspecified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 110 of file dlat2s.f.

111*
112* -- LAPACK auxiliary routine --
113* -- LAPACK is a software package provided by Univ. of Tennessee, --
114* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
115*
116* .. Scalar Arguments ..
117 CHARACTER UPLO
118 INTEGER INFO, LDA, LDSA, N
119* ..
120* .. Array Arguments ..
121 REAL SA( LDSA, * )
122 DOUBLE PRECISION A( LDA, * )
123* ..
124*
125* =====================================================================
126*
127* .. Local Scalars ..
128 INTEGER I, J
129 DOUBLE PRECISION RMAX
130 LOGICAL UPPER
131* ..
132* .. External Functions ..
133 REAL SLAMCH
134 LOGICAL LSAME
135 EXTERNAL slamch, lsame
136* ..
137* .. Executable Statements ..
138*
139 rmax = slamch( 'O' )
140 upper = lsame( uplo, 'U' )
141 IF( upper ) THEN
142 DO 20 j = 1, n
143 DO 10 i = 1, j
144 IF( ( a( i, j ).LT.-rmax ) .OR. ( a( i, j ).GT.rmax ) )
145 $ THEN
146 info = 1
147 GO TO 50
148 END IF
149 sa( i, j ) = a( i, j )
150 10 CONTINUE
151 20 CONTINUE
152 ELSE
153 DO 40 j = 1, n
154 DO 30 i = j, n
155 IF( ( a( i, j ).LT.-rmax ) .OR. ( a( i, j ).GT.rmax ) )
156 $ THEN
157 info = 1
158 GO TO 50
159 END IF
160 sa( i, j ) = a( i, j )
161 30 CONTINUE
162 40 CONTINUE
163 END IF
164 50 CONTINUE
165*
166 RETURN
167*
168* End of DLAT2S
169*

◆ dlatbs()

subroutine dlatbs ( character uplo,
character trans,
character diag,
character normin,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) x,
double precision scale,
double precision, dimension( * ) cnorm,
integer info )

DLATBS solves a triangular banded system of equations.

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

Purpose:
!>
!> DLATBS solves one of the triangular systems
!>
!>    A *x = s*b  or  A**T*x = s*b
!>
!> with scaling to prevent overflow, where A is an upper or lower
!> triangular band matrix.  Here A**T denotes the transpose of A, x and b
!> are n-element vectors, and s is a scaling factor, usually less than
!> or equal to 1, chosen so that the components of x will be less than
!> the overflow threshold.  If the unscaled problem will not cause
!> overflow, the Level 2 BLAS routine DTBSV is called.  If the matrix A
!> is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!> non-trivial solution to A*x = 0 is returned.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  Solve A * x = s*b  (No transpose)
!>          = 'T':  Solve A**T* x = s*b  (Transpose)
!>          = 'C':  Solve A**T* x = s*b  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]NORMIN
!>          NORMIN is CHARACTER*1
!>          Specifies whether CNORM has been set or not.
!>          = 'Y':  CNORM contains the column norms on entry
!>          = 'N':  CNORM is not set on entry.  On exit, the norms will
!>                  be computed and stored in CNORM.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of subdiagonals or superdiagonals in the
!>          triangular matrix A.  KD >= 0.
!>
[in]AB
!>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first KD+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b  or  A**T* x = s*b.
!>          If SCALE = 0, the matrix A is singular or badly scaled, and
!>          the vector x is an exact or approximate solution to A*x = 0.
!>
[in,out]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, DTBSV
!>  is called, otherwise, specific code is used which checks for possible
!>  overflow or divide-by-zero at every operation.
!>
!>  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!>  if A is lower triangular is
!>
!>       x[1:n] := b[1:n]
!>       for j = 1, ..., n
!>            x(j) := x(j) / A(j,j)
!>            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!>       end
!>
!>  Define bounds on the components of x after j iterations of the loop:
!>     M(j) = bound on x[1:j]
!>     G(j) = bound on x[j+1:n]
!>  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!>
!>  Then for iteration j+1 we have
!>     M(j+1) <= G(j) / | A(j+1,j+1) |
!>     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!>            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!>
!>  where CNORM(j+1) is greater than or equal to the infinity-norm of
!>  column j+1 of A, not counting the diagonal.  Hence
!>
!>     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!>                  1<=i<=j
!>  and
!>
!>     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!>                                   1<=i< j
!>
!>  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
!>  reciprocal of the largest M(j), j=1,..,n, is larger than
!>  max(underflow, 1/overflow).
!>
!>  The bound on x(j) is also used to determine when a step in the
!>  columnwise method can be performed without fear of overflow.  If
!>  the computed bound is greater than a large constant, x is scaled to
!>  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!>  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!>
!>  Similarly, a row-wise scheme is used to solve A**T*x = b.  The basic
!>  algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j
!>       M(j) = bound on x(i), 1<=i<=j
!>
!>  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!>  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!>  Then the bound on x(j) is
!>
!>       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!>
!>            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!>                      1<=i<=j
!>
!>  and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 240 of file dlatbs.f.

242*
243* -- LAPACK auxiliary routine --
244* -- LAPACK is a software package provided by Univ. of Tennessee, --
245* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
246*
247* .. Scalar Arguments ..
248 CHARACTER DIAG, NORMIN, TRANS, UPLO
249 INTEGER INFO, KD, LDAB, N
250 DOUBLE PRECISION SCALE
251* ..
252* .. Array Arguments ..
253 DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * )
254* ..
255*
256* =====================================================================
257*
258* .. Parameters ..
259 DOUBLE PRECISION ZERO, HALF, ONE
260 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0 )
261* ..
262* .. Local Scalars ..
263 LOGICAL NOTRAN, NOUNIT, UPPER
264 INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
265 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
266 $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
267* ..
268* .. External Functions ..
269 LOGICAL LSAME
270 INTEGER IDAMAX
271 DOUBLE PRECISION DASUM, DDOT, DLAMCH
272 EXTERNAL lsame, idamax, dasum, ddot, dlamch
273* ..
274* .. External Subroutines ..
275 EXTERNAL daxpy, dscal, dtbsv, xerbla
276* ..
277* .. Intrinsic Functions ..
278 INTRINSIC abs, max, min
279* ..
280* .. Executable Statements ..
281*
282 info = 0
283 upper = lsame( uplo, 'U' )
284 notran = lsame( trans, 'N' )
285 nounit = lsame( diag, 'N' )
286*
287* Test the input parameters.
288*
289 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
290 info = -1
291 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
292 $ lsame( trans, 'C' ) ) THEN
293 info = -2
294 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
295 info = -3
296 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
297 $ lsame( normin, 'N' ) ) THEN
298 info = -4
299 ELSE IF( n.LT.0 ) THEN
300 info = -5
301 ELSE IF( kd.LT.0 ) THEN
302 info = -6
303 ELSE IF( ldab.LT.kd+1 ) THEN
304 info = -8
305 END IF
306 IF( info.NE.0 ) THEN
307 CALL xerbla( 'DLATBS', -info )
308 RETURN
309 END IF
310*
311* Quick return if possible
312*
313 IF( n.EQ.0 )
314 $ RETURN
315*
316* Determine machine dependent parameters to control overflow.
317*
318 smlnum = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
319 bignum = one / smlnum
320 scale = one
321*
322 IF( lsame( normin, 'N' ) ) THEN
323*
324* Compute the 1-norm of each column, not including the diagonal.
325*
326 IF( upper ) THEN
327*
328* A is upper triangular.
329*
330 DO 10 j = 1, n
331 jlen = min( kd, j-1 )
332 cnorm( j ) = dasum( jlen, ab( kd+1-jlen, j ), 1 )
333 10 CONTINUE
334 ELSE
335*
336* A is lower triangular.
337*
338 DO 20 j = 1, n
339 jlen = min( kd, n-j )
340 IF( jlen.GT.0 ) THEN
341 cnorm( j ) = dasum( jlen, ab( 2, j ), 1 )
342 ELSE
343 cnorm( j ) = zero
344 END IF
345 20 CONTINUE
346 END IF
347 END IF
348*
349* Scale the column norms by TSCAL if the maximum element in CNORM is
350* greater than BIGNUM.
351*
352 imax = idamax( n, cnorm, 1 )
353 tmax = cnorm( imax )
354 IF( tmax.LE.bignum ) THEN
355 tscal = one
356 ELSE
357 tscal = one / ( smlnum*tmax )
358 CALL dscal( n, tscal, cnorm, 1 )
359 END IF
360*
361* Compute a bound on the computed solution vector to see if the
362* Level 2 BLAS routine DTBSV can be used.
363*
364 j = idamax( n, x, 1 )
365 xmax = abs( x( j ) )
366 xbnd = xmax
367 IF( notran ) THEN
368*
369* Compute the growth in A * x = b.
370*
371 IF( upper ) THEN
372 jfirst = n
373 jlast = 1
374 jinc = -1
375 maind = kd + 1
376 ELSE
377 jfirst = 1
378 jlast = n
379 jinc = 1
380 maind = 1
381 END IF
382*
383 IF( tscal.NE.one ) THEN
384 grow = zero
385 GO TO 50
386 END IF
387*
388 IF( nounit ) THEN
389*
390* A is non-unit triangular.
391*
392* Compute GROW = 1/G(j) and XBND = 1/M(j).
393* Initially, G(0) = max{x(i), i=1,...,n}.
394*
395 grow = one / max( xbnd, smlnum )
396 xbnd = grow
397 DO 30 j = jfirst, jlast, jinc
398*
399* Exit the loop if the growth factor is too small.
400*
401 IF( grow.LE.smlnum )
402 $ GO TO 50
403*
404* M(j) = G(j-1) / abs(A(j,j))
405*
406 tjj = abs( ab( maind, j ) )
407 xbnd = min( xbnd, min( one, tjj )*grow )
408 IF( tjj+cnorm( j ).GE.smlnum ) THEN
409*
410* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
411*
412 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
413 ELSE
414*
415* G(j) could overflow, set GROW to 0.
416*
417 grow = zero
418 END IF
419 30 CONTINUE
420 grow = xbnd
421 ELSE
422*
423* A is unit triangular.
424*
425* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
426*
427 grow = min( one, one / max( xbnd, smlnum ) )
428 DO 40 j = jfirst, jlast, jinc
429*
430* Exit the loop if the growth factor is too small.
431*
432 IF( grow.LE.smlnum )
433 $ GO TO 50
434*
435* G(j) = G(j-1)*( 1 + CNORM(j) )
436*
437 grow = grow*( one / ( one+cnorm( j ) ) )
438 40 CONTINUE
439 END IF
440 50 CONTINUE
441*
442 ELSE
443*
444* Compute the growth in A**T * x = b.
445*
446 IF( upper ) THEN
447 jfirst = 1
448 jlast = n
449 jinc = 1
450 maind = kd + 1
451 ELSE
452 jfirst = n
453 jlast = 1
454 jinc = -1
455 maind = 1
456 END IF
457*
458 IF( tscal.NE.one ) THEN
459 grow = zero
460 GO TO 80
461 END IF
462*
463 IF( nounit ) THEN
464*
465* A is non-unit triangular.
466*
467* Compute GROW = 1/G(j) and XBND = 1/M(j).
468* Initially, M(0) = max{x(i), i=1,...,n}.
469*
470 grow = one / max( xbnd, smlnum )
471 xbnd = grow
472 DO 60 j = jfirst, jlast, jinc
473*
474* Exit the loop if the growth factor is too small.
475*
476 IF( grow.LE.smlnum )
477 $ GO TO 80
478*
479* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
480*
481 xj = one + cnorm( j )
482 grow = min( grow, xbnd / xj )
483*
484* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
485*
486 tjj = abs( ab( maind, j ) )
487 IF( xj.GT.tjj )
488 $ xbnd = xbnd*( tjj / xj )
489 60 CONTINUE
490 grow = min( grow, xbnd )
491 ELSE
492*
493* A is unit triangular.
494*
495* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
496*
497 grow = min( one, one / max( xbnd, smlnum ) )
498 DO 70 j = jfirst, jlast, jinc
499*
500* Exit the loop if the growth factor is too small.
501*
502 IF( grow.LE.smlnum )
503 $ GO TO 80
504*
505* G(j) = ( 1 + CNORM(j) )*G(j-1)
506*
507 xj = one + cnorm( j )
508 grow = grow / xj
509 70 CONTINUE
510 END IF
511 80 CONTINUE
512 END IF
513*
514 IF( ( grow*tscal ).GT.smlnum ) THEN
515*
516* Use the Level 2 BLAS solve if the reciprocal of the bound on
517* elements of X is not too small.
518*
519 CALL dtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 )
520 ELSE
521*
522* Use a Level 1 BLAS solve, scaling intermediate results.
523*
524 IF( xmax.GT.bignum ) THEN
525*
526* Scale X so that its components are less than or equal to
527* BIGNUM in absolute value.
528*
529 scale = bignum / xmax
530 CALL dscal( n, scale, x, 1 )
531 xmax = bignum
532 END IF
533*
534 IF( notran ) THEN
535*
536* Solve A * x = b
537*
538 DO 110 j = jfirst, jlast, jinc
539*
540* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
541*
542 xj = abs( x( j ) )
543 IF( nounit ) THEN
544 tjjs = ab( maind, j )*tscal
545 ELSE
546 tjjs = tscal
547 IF( tscal.EQ.one )
548 $ GO TO 100
549 END IF
550 tjj = abs( tjjs )
551 IF( tjj.GT.smlnum ) THEN
552*
553* abs(A(j,j)) > SMLNUM:
554*
555 IF( tjj.LT.one ) THEN
556 IF( xj.GT.tjj*bignum ) THEN
557*
558* Scale x by 1/b(j).
559*
560 rec = one / xj
561 CALL dscal( n, rec, x, 1 )
562 scale = scale*rec
563 xmax = xmax*rec
564 END IF
565 END IF
566 x( j ) = x( j ) / tjjs
567 xj = abs( x( j ) )
568 ELSE IF( tjj.GT.zero ) THEN
569*
570* 0 < abs(A(j,j)) <= SMLNUM:
571*
572 IF( xj.GT.tjj*bignum ) THEN
573*
574* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
575* to avoid overflow when dividing by A(j,j).
576*
577 rec = ( tjj*bignum ) / xj
578 IF( cnorm( j ).GT.one ) THEN
579*
580* Scale by 1/CNORM(j) to avoid overflow when
581* multiplying x(j) times column j.
582*
583 rec = rec / cnorm( j )
584 END IF
585 CALL dscal( n, rec, x, 1 )
586 scale = scale*rec
587 xmax = xmax*rec
588 END IF
589 x( j ) = x( j ) / tjjs
590 xj = abs( x( j ) )
591 ELSE
592*
593* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
594* scale = 0, and compute a solution to A*x = 0.
595*
596 DO 90 i = 1, n
597 x( i ) = zero
598 90 CONTINUE
599 x( j ) = one
600 xj = one
601 scale = zero
602 xmax = zero
603 END IF
604 100 CONTINUE
605*
606* Scale x if necessary to avoid overflow when adding a
607* multiple of column j of A.
608*
609 IF( xj.GT.one ) THEN
610 rec = one / xj
611 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
612*
613* Scale x by 1/(2*abs(x(j))).
614*
615 rec = rec*half
616 CALL dscal( n, rec, x, 1 )
617 scale = scale*rec
618 END IF
619 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
620*
621* Scale x by 1/2.
622*
623 CALL dscal( n, half, x, 1 )
624 scale = scale*half
625 END IF
626*
627 IF( upper ) THEN
628 IF( j.GT.1 ) THEN
629*
630* Compute the update
631* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
632* x(j)* A(max(1,j-kd):j-1,j)
633*
634 jlen = min( kd, j-1 )
635 CALL daxpy( jlen, -x( j )*tscal,
636 $ ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 )
637 i = idamax( j-1, x, 1 )
638 xmax = abs( x( i ) )
639 END IF
640 ELSE IF( j.LT.n ) THEN
641*
642* Compute the update
643* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
644* x(j) * A(j+1:min(j+kd,n),j)
645*
646 jlen = min( kd, n-j )
647 IF( jlen.GT.0 )
648 $ CALL daxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,
649 $ x( j+1 ), 1 )
650 i = j + idamax( n-j, x( j+1 ), 1 )
651 xmax = abs( x( i ) )
652 END IF
653 110 CONTINUE
654*
655 ELSE
656*
657* Solve A**T * x = b
658*
659 DO 160 j = jfirst, jlast, jinc
660*
661* Compute x(j) = b(j) - sum A(k,j)*x(k).
662* k<>j
663*
664 xj = abs( x( j ) )
665 uscal = tscal
666 rec = one / max( xmax, one )
667 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
668*
669* If x(j) could overflow, scale x by 1/(2*XMAX).
670*
671 rec = rec*half
672 IF( nounit ) THEN
673 tjjs = ab( maind, j )*tscal
674 ELSE
675 tjjs = tscal
676 END IF
677 tjj = abs( tjjs )
678 IF( tjj.GT.one ) THEN
679*
680* Divide by A(j,j) when scaling x if A(j,j) > 1.
681*
682 rec = min( one, rec*tjj )
683 uscal = uscal / tjjs
684 END IF
685 IF( rec.LT.one ) THEN
686 CALL dscal( n, rec, x, 1 )
687 scale = scale*rec
688 xmax = xmax*rec
689 END IF
690 END IF
691*
692 sumj = zero
693 IF( uscal.EQ.one ) THEN
694*
695* If the scaling needed for A in the dot product is 1,
696* call DDOT to perform the dot product.
697*
698 IF( upper ) THEN
699 jlen = min( kd, j-1 )
700 sumj = ddot( jlen, ab( kd+1-jlen, j ), 1,
701 $ x( j-jlen ), 1 )
702 ELSE
703 jlen = min( kd, n-j )
704 IF( jlen.GT.0 )
705 $ sumj = ddot( jlen, ab( 2, j ), 1, x( j+1 ), 1 )
706 END IF
707 ELSE
708*
709* Otherwise, use in-line code for the dot product.
710*
711 IF( upper ) THEN
712 jlen = min( kd, j-1 )
713 DO 120 i = 1, jlen
714 sumj = sumj + ( ab( kd+i-jlen, j )*uscal )*
715 $ x( j-jlen-1+i )
716 120 CONTINUE
717 ELSE
718 jlen = min( kd, n-j )
719 DO 130 i = 1, jlen
720 sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i )
721 130 CONTINUE
722 END IF
723 END IF
724*
725 IF( uscal.EQ.tscal ) THEN
726*
727* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
728* was not used to scale the dotproduct.
729*
730 x( j ) = x( j ) - sumj
731 xj = abs( x( j ) )
732 IF( nounit ) THEN
733*
734* Compute x(j) = x(j) / A(j,j), scaling if necessary.
735*
736 tjjs = ab( maind, j )*tscal
737 ELSE
738 tjjs = tscal
739 IF( tscal.EQ.one )
740 $ GO TO 150
741 END IF
742 tjj = abs( tjjs )
743 IF( tjj.GT.smlnum ) THEN
744*
745* abs(A(j,j)) > SMLNUM:
746*
747 IF( tjj.LT.one ) THEN
748 IF( xj.GT.tjj*bignum ) THEN
749*
750* Scale X by 1/abs(x(j)).
751*
752 rec = one / xj
753 CALL dscal( n, rec, x, 1 )
754 scale = scale*rec
755 xmax = xmax*rec
756 END IF
757 END IF
758 x( j ) = x( j ) / tjjs
759 ELSE IF( tjj.GT.zero ) THEN
760*
761* 0 < abs(A(j,j)) <= SMLNUM:
762*
763 IF( xj.GT.tjj*bignum ) THEN
764*
765* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
766*
767 rec = ( tjj*bignum ) / xj
768 CALL dscal( n, rec, x, 1 )
769 scale = scale*rec
770 xmax = xmax*rec
771 END IF
772 x( j ) = x( j ) / tjjs
773 ELSE
774*
775* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
776* scale = 0, and compute a solution to A**T*x = 0.
777*
778 DO 140 i = 1, n
779 x( i ) = zero
780 140 CONTINUE
781 x( j ) = one
782 scale = zero
783 xmax = zero
784 END IF
785 150 CONTINUE
786 ELSE
787*
788* Compute x(j) := x(j) / A(j,j) - sumj if the dot
789* product has already been divided by 1/A(j,j).
790*
791 x( j ) = x( j ) / tjjs - sumj
792 END IF
793 xmax = max( xmax, abs( x( j ) ) )
794 160 CONTINUE
795 END IF
796 scale = scale / tscal
797 END IF
798*
799* Scale the column norms by 1/TSCAL for return.
800*
801 IF( tscal.NE.one ) THEN
802 CALL dscal( n, one / tscal, cnorm, 1 )
803 END IF
804*
805 RETURN
806*
807* End of DLATBS
808*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
dtbsv
subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBSV
Definition dtbsv.f:189

◆ dlatdf()

subroutine dlatdf ( integer ijob,
integer n,
double precision, dimension( ldz, * ) z,
integer ldz,
double precision, dimension( * ) rhs,
double precision rdsum,
double precision rdscal,
integer, dimension( * ) ipiv,
integer, dimension( * ) jpiv )

DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.

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

Purpose:
!>
!> DLATDF uses the LU factorization of the n-by-n matrix Z computed by
!> DGETC2 and computes a contribution to the reciprocal Dif-estimate
!> by solving Z * x = b for x, and choosing the r.h.s. b such that
!> the norm of x is as large as possible. On entry RHS = b holds the
!> contribution from earlier solved sub-systems, and on return RHS = x.
!>
!> The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
!> where P and Q are permutation matrices. L is lower triangular with
!> unit diagonal elements and U is upper triangular.
!>
Parameters
[in]IJOB
!>          IJOB is INTEGER
!>          IJOB = 2: First compute an approximative null-vector e
!>              of Z using DGECON, e is normalized and solve for
!>              Zx = +-e - f with the sign giving the greater value
!>              of 2-norm(x). About 5 times as expensive as Default.
!>          IJOB .ne. 2: Local look ahead strategy where all entries of
!>              the r.h.s. b is chosen as either +1 or -1 (Default).
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Z.
!>
[in]Z
!>          Z is DOUBLE PRECISION array, dimension (LDZ, N)
!>          On entry, the LU part of the factorization of the n-by-n
!>          matrix Z computed by DGETC2:  Z = P * L * U * Q
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDA >= max(1, N).
!>
[in,out]RHS
!>          RHS is DOUBLE PRECISION array, dimension (N)
!>          On entry, RHS contains contributions from other subsystems.
!>          On exit, RHS contains the solution of the subsystem with
!>          entries according to the value of IJOB (see above).
!>
[in,out]RDSUM
!>          RDSUM is DOUBLE PRECISION
!>          On entry, the sum of squares of computed contributions to
!>          the Dif-estimate under computation by DTGSYL, where the
!>          scaling factor RDSCAL (see below) has been factored out.
!>          On exit, the corresponding sum of squares updated with the
!>          contributions from the current sub-system.
!>          If TRANS = 'T' RDSUM is not touched.
!>          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
!>
[in,out]RDSCAL
!>          RDSCAL is DOUBLE PRECISION
!>          On entry, scaling factor used to prevent overflow in RDSUM.
!>          On exit, RDSCAL is updated w.r.t. the current contributions
!>          in RDSUM.
!>          If TRANS = 'T', RDSCAL is not touched.
!>          NOTE: RDSCAL only makes sense when DTGSY2 is called by
!>                DTGSYL.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N).
!>          The pivot indices; for 1 <= i <= N, row i of the
!>          matrix has been interchanged with row IPIV(i).
!>
[in]JPIV
!>          JPIV is INTEGER array, dimension (N).
!>          The pivot indices; for 1 <= j <= N, column j of the
!>          matrix has been interchanged with column JPIV(j).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
This routine is a further developed implementation of algorithm BSOLVE in [1] using complete pivoting in the LU factorization.
Contributors:
Bo Kagstrom and Peter Poromaa, Department of Computing Science, Umea University, S-901 87 Umea, Sweden.
References:
!>
!>
!>  [1] Bo Kagstrom and Lars Westin,
!>      Generalized Schur Methods with Condition Estimators for
!>      Solving the Generalized Sylvester Equation, IEEE Transactions
!>      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
!>
!>  [2] Peter Poromaa,
!>      On Efficient and Robust Estimators for the Separation
!>      between two Regular Matrix Pairs with Applications in
!>      Condition Estimation. Report IMINF-95.05, Departement of
!>      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
!>

Definition at line 169 of file dlatdf.f.

171*
172* -- LAPACK auxiliary routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 INTEGER IJOB, LDZ, N
178 DOUBLE PRECISION RDSCAL, RDSUM
179* ..
180* .. Array Arguments ..
181 INTEGER IPIV( * ), JPIV( * )
182 DOUBLE PRECISION RHS( * ), Z( LDZ, * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 INTEGER MAXDIM
189 parameter( maxdim = 8 )
190 DOUBLE PRECISION ZERO, ONE
191 parameter( zero = 0.0d+0, one = 1.0d+0 )
192* ..
193* .. Local Scalars ..
194 INTEGER I, INFO, J, K
195 DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP
196* ..
197* .. Local Arrays ..
198 INTEGER IWORK( MAXDIM )
199 DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
200* ..
201* .. External Subroutines ..
202 EXTERNAL daxpy, dcopy, dgecon, dgesc2, dlassq, dlaswp,
203 $ dscal
204* ..
205* .. External Functions ..
206 DOUBLE PRECISION DASUM, DDOT
207 EXTERNAL dasum, ddot
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, sqrt
211* ..
212* .. Executable Statements ..
213*
214 IF( ijob.NE.2 ) THEN
215*
216* Apply permutations IPIV to RHS
217*
218 CALL dlaswp( 1, rhs, ldz, 1, n-1, ipiv, 1 )
219*
220* Solve for L-part choosing RHS either to +1 or -1.
221*
222 pmone = -one
223*
224 DO 10 j = 1, n - 1
225 bp = rhs( j ) + one
226 bm = rhs( j ) - one
227 splus = one
228*
229* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
230* SMIN computed more efficiently than in BSOLVE [1].
231*
232 splus = splus + ddot( n-j, z( j+1, j ), 1, z( j+1, j ), 1 )
233 sminu = ddot( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 )
234 splus = splus*rhs( j )
235 IF( splus.GT.sminu ) THEN
236 rhs( j ) = bp
237 ELSE IF( sminu.GT.splus ) THEN
238 rhs( j ) = bm
239 ELSE
240*
241* In this case the updating sums are equal and we can
242* choose RHS(J) +1 or -1. The first time this happens
243* we choose -1, thereafter +1. This is a simple way to
244* get good estimates of matrices like Byers well-known
245* example (see [1]). (Not done in BSOLVE.)
246*
247 rhs( j ) = rhs( j ) + pmone
248 pmone = one
249 END IF
250*
251* Compute the remaining r.h.s.
252*
253 temp = -rhs( j )
254 CALL daxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 )
255*
256 10 CONTINUE
257*
258* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
259* in BSOLVE and will hopefully give us a better estimate because
260* any ill-conditioning of the original matrix is transferred to U
261* and not to L. U(N, N) is an approximation to sigma_min(LU).
262*
263 CALL dcopy( n-1, rhs, 1, xp, 1 )
264 xp( n ) = rhs( n ) + one
265 rhs( n ) = rhs( n ) - one
266 splus = zero
267 sminu = zero
268 DO 30 i = n, 1, -1
269 temp = one / z( i, i )
270 xp( i ) = xp( i )*temp
271 rhs( i ) = rhs( i )*temp
272 DO 20 k = i + 1, n
273 xp( i ) = xp( i ) - xp( k )*( z( i, k )*temp )
274 rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp )
275 20 CONTINUE
276 splus = splus + abs( xp( i ) )
277 sminu = sminu + abs( rhs( i ) )
278 30 CONTINUE
279 IF( splus.GT.sminu )
280 $ CALL dcopy( n, xp, 1, rhs, 1 )
281*
282* Apply the permutations JPIV to the computed solution (RHS)
283*
284 CALL dlaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 )
285*
286* Compute the sum of squares
287*
288 CALL dlassq( n, rhs, 1, rdscal, rdsum )
289*
290 ELSE
291*
292* IJOB = 2, Compute approximate nullvector XM of Z
293*
294 CALL dgecon( 'I', n, z, ldz, one, temp, work, iwork, info )
295 CALL dcopy( n, work( n+1 ), 1, xm, 1 )
296*
297* Compute RHS
298*
299 CALL dlaswp( 1, xm, ldz, 1, n-1, ipiv, -1 )
300 temp = one / sqrt( ddot( n, xm, 1, xm, 1 ) )
301 CALL dscal( n, temp, xm, 1 )
302 CALL dcopy( n, xm, 1, xp, 1 )
303 CALL daxpy( n, one, rhs, 1, xp, 1 )
304 CALL daxpy( n, -one, xm, 1, rhs, 1 )
305 CALL dgesc2( n, z, ldz, rhs, ipiv, jpiv, temp )
306 CALL dgesc2( n, z, ldz, xp, ipiv, jpiv, temp )
307 IF( dasum( n, xp, 1 ).GT.dasum( n, rhs, 1 ) )
308 $ CALL dcopy( n, xp, 1, rhs, 1 )
309*
310* Compute the sum of squares
311*
312 CALL dlassq( n, rhs, 1, rdscal, rdsum )
313*
314 END IF
315*
316 RETURN
317*
318* End of DLATDF
319*
dgesc2
subroutine dgesc2(n, a, lda, rhs, ipiv, jpiv, scale)
DGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed...
Definition dgesc2.f:114
dgecon
subroutine dgecon(norm, n, a, lda, anorm, rcond, work, iwork, info)
DGECON
Definition dgecon.f:124
dlaswp
subroutine dlaswp(n, a, lda, k1, k2, ipiv, incx)
DLASWP performs a series of row interchanges on a general rectangular matrix.
Definition dlaswp.f:115

◆ dlatps()

subroutine dlatps ( character uplo,
character trans,
character diag,
character normin,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) x,
double precision scale,
double precision, dimension( * ) cnorm,
integer info )

DLATPS solves a triangular system of equations with the matrix held in packed storage.

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

Purpose:
!>
!> DLATPS solves one of the triangular systems
!>
!>    A *x = s*b  or  A**T*x = s*b
!>
!> with scaling to prevent overflow, where A is an upper or lower
!> triangular matrix stored in packed form.  Here A**T denotes the
!> transpose of A, x and b are n-element vectors, and s is a scaling
!> factor, usually less than or equal to 1, chosen so that the
!> components of x will be less than the overflow threshold.  If the
!> unscaled problem will not cause overflow, the Level 2 BLAS routine
!> DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
!> then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  Solve A * x = s*b  (No transpose)
!>          = 'T':  Solve A**T* x = s*b  (Transpose)
!>          = 'C':  Solve A**T* x = s*b  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]NORMIN
!>          NORMIN is CHARACTER*1
!>          Specifies whether CNORM has been set or not.
!>          = 'Y':  CNORM contains the column norms on entry
!>          = 'N':  CNORM is not set on entry.  On exit, the norms will
!>                  be computed and stored in CNORM.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]AP
!>          AP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b  or  A**T* x = s*b.
!>          If SCALE = 0, the matrix A is singular or badly scaled, and
!>          the vector x is an exact or approximate solution to A*x = 0.
!>
[in,out]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, DTPSV
!>  is called, otherwise, specific code is used which checks for possible
!>  overflow or divide-by-zero at every operation.
!>
!>  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!>  if A is lower triangular is
!>
!>       x[1:n] := b[1:n]
!>       for j = 1, ..., n
!>            x(j) := x(j) / A(j,j)
!>            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!>       end
!>
!>  Define bounds on the components of x after j iterations of the loop:
!>     M(j) = bound on x[1:j]
!>     G(j) = bound on x[j+1:n]
!>  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!>
!>  Then for iteration j+1 we have
!>     M(j+1) <= G(j) / | A(j+1,j+1) |
!>     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!>            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!>
!>  where CNORM(j+1) is greater than or equal to the infinity-norm of
!>  column j+1 of A, not counting the diagonal.  Hence
!>
!>     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!>                  1<=i<=j
!>  and
!>
!>     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!>                                   1<=i< j
!>
!>  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the
!>  reciprocal of the largest M(j), j=1,..,n, is larger than
!>  max(underflow, 1/overflow).
!>
!>  The bound on x(j) is also used to determine when a step in the
!>  columnwise method can be performed without fear of overflow.  If
!>  the computed bound is greater than a large constant, x is scaled to
!>  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!>  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!>
!>  Similarly, a row-wise scheme is used to solve A**T*x = b.  The basic
!>  algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j
!>       M(j) = bound on x(i), 1<=i<=j
!>
!>  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!>  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!>  Then the bound on x(j) is
!>
!>       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!>
!>            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!>                      1<=i<=j
!>
!>  and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 227 of file dlatps.f.

229*
230* -- LAPACK auxiliary routine --
231* -- LAPACK is a software package provided by Univ. of Tennessee, --
232* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
233*
234* .. Scalar Arguments ..
235 CHARACTER DIAG, NORMIN, TRANS, UPLO
236 INTEGER INFO, N
237 DOUBLE PRECISION SCALE
238* ..
239* .. Array Arguments ..
240 DOUBLE PRECISION AP( * ), CNORM( * ), X( * )
241* ..
242*
243* =====================================================================
244*
245* .. Parameters ..
246 DOUBLE PRECISION ZERO, HALF, ONE
247 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0 )
248* ..
249* .. Local Scalars ..
250 LOGICAL NOTRAN, NOUNIT, UPPER
251 INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
252 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
253 $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
254* ..
255* .. External Functions ..
256 LOGICAL LSAME
257 INTEGER IDAMAX
258 DOUBLE PRECISION DASUM, DDOT, DLAMCH
259 EXTERNAL lsame, idamax, dasum, ddot, dlamch
260* ..
261* .. External Subroutines ..
262 EXTERNAL daxpy, dscal, dtpsv, xerbla
263* ..
264* .. Intrinsic Functions ..
265 INTRINSIC abs, max, min
266* ..
267* .. Executable Statements ..
268*
269 info = 0
270 upper = lsame( uplo, 'U' )
271 notran = lsame( trans, 'N' )
272 nounit = lsame( diag, 'N' )
273*
274* Test the input parameters.
275*
276 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
277 info = -1
278 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
279 $ lsame( trans, 'C' ) ) THEN
280 info = -2
281 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
282 info = -3
283 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
284 $ lsame( normin, 'N' ) ) THEN
285 info = -4
286 ELSE IF( n.LT.0 ) THEN
287 info = -5
288 END IF
289 IF( info.NE.0 ) THEN
290 CALL xerbla( 'DLATPS', -info )
291 RETURN
292 END IF
293*
294* Quick return if possible
295*
296 IF( n.EQ.0 )
297 $ RETURN
298*
299* Determine machine dependent parameters to control overflow.
300*
301 smlnum = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
302 bignum = one / smlnum
303 scale = one
304*
305 IF( lsame( normin, 'N' ) ) THEN
306*
307* Compute the 1-norm of each column, not including the diagonal.
308*
309 IF( upper ) THEN
310*
311* A is upper triangular.
312*
313 ip = 1
314 DO 10 j = 1, n
315 cnorm( j ) = dasum( j-1, ap( ip ), 1 )
316 ip = ip + j
317 10 CONTINUE
318 ELSE
319*
320* A is lower triangular.
321*
322 ip = 1
323 DO 20 j = 1, n - 1
324 cnorm( j ) = dasum( n-j, ap( ip+1 ), 1 )
325 ip = ip + n - j + 1
326 20 CONTINUE
327 cnorm( n ) = zero
328 END IF
329 END IF
330*
331* Scale the column norms by TSCAL if the maximum element in CNORM is
332* greater than BIGNUM.
333*
334 imax = idamax( n, cnorm, 1 )
335 tmax = cnorm( imax )
336 IF( tmax.LE.bignum ) THEN
337 tscal = one
338 ELSE
339 tscal = one / ( smlnum*tmax )
340 CALL dscal( n, tscal, cnorm, 1 )
341 END IF
342*
343* Compute a bound on the computed solution vector to see if the
344* Level 2 BLAS routine DTPSV can be used.
345*
346 j = idamax( n, x, 1 )
347 xmax = abs( x( j ) )
348 xbnd = xmax
349 IF( notran ) THEN
350*
351* Compute the growth in A * x = b.
352*
353 IF( upper ) THEN
354 jfirst = n
355 jlast = 1
356 jinc = -1
357 ELSE
358 jfirst = 1
359 jlast = n
360 jinc = 1
361 END IF
362*
363 IF( tscal.NE.one ) THEN
364 grow = zero
365 GO TO 50
366 END IF
367*
368 IF( nounit ) THEN
369*
370* A is non-unit triangular.
371*
372* Compute GROW = 1/G(j) and XBND = 1/M(j).
373* Initially, G(0) = max{x(i), i=1,...,n}.
374*
375 grow = one / max( xbnd, smlnum )
376 xbnd = grow
377 ip = jfirst*( jfirst+1 ) / 2
378 jlen = n
379 DO 30 j = jfirst, jlast, jinc
380*
381* Exit the loop if the growth factor is too small.
382*
383 IF( grow.LE.smlnum )
384 $ GO TO 50
385*
386* M(j) = G(j-1) / abs(A(j,j))
387*
388 tjj = abs( ap( ip ) )
389 xbnd = min( xbnd, min( one, tjj )*grow )
390 IF( tjj+cnorm( j ).GE.smlnum ) THEN
391*
392* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
393*
394 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
395 ELSE
396*
397* G(j) could overflow, set GROW to 0.
398*
399 grow = zero
400 END IF
401 ip = ip + jinc*jlen
402 jlen = jlen - 1
403 30 CONTINUE
404 grow = xbnd
405 ELSE
406*
407* A is unit triangular.
408*
409* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
410*
411 grow = min( one, one / max( xbnd, smlnum ) )
412 DO 40 j = jfirst, jlast, jinc
413*
414* Exit the loop if the growth factor is too small.
415*
416 IF( grow.LE.smlnum )
417 $ GO TO 50
418*
419* G(j) = G(j-1)*( 1 + CNORM(j) )
420*
421 grow = grow*( one / ( one+cnorm( j ) ) )
422 40 CONTINUE
423 END IF
424 50 CONTINUE
425*
426 ELSE
427*
428* Compute the growth in A**T * x = b.
429*
430 IF( upper ) THEN
431 jfirst = 1
432 jlast = n
433 jinc = 1
434 ELSE
435 jfirst = n
436 jlast = 1
437 jinc = -1
438 END IF
439*
440 IF( tscal.NE.one ) THEN
441 grow = zero
442 GO TO 80
443 END IF
444*
445 IF( nounit ) THEN
446*
447* A is non-unit triangular.
448*
449* Compute GROW = 1/G(j) and XBND = 1/M(j).
450* Initially, M(0) = max{x(i), i=1,...,n}.
451*
452 grow = one / max( xbnd, smlnum )
453 xbnd = grow
454 ip = jfirst*( jfirst+1 ) / 2
455 jlen = 1
456 DO 60 j = jfirst, jlast, jinc
457*
458* Exit the loop if the growth factor is too small.
459*
460 IF( grow.LE.smlnum )
461 $ GO TO 80
462*
463* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
464*
465 xj = one + cnorm( j )
466 grow = min( grow, xbnd / xj )
467*
468* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
469*
470 tjj = abs( ap( ip ) )
471 IF( xj.GT.tjj )
472 $ xbnd = xbnd*( tjj / xj )
473 jlen = jlen + 1
474 ip = ip + jinc*jlen
475 60 CONTINUE
476 grow = min( grow, xbnd )
477 ELSE
478*
479* A is unit triangular.
480*
481* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
482*
483 grow = min( one, one / max( xbnd, smlnum ) )
484 DO 70 j = jfirst, jlast, jinc
485*
486* Exit the loop if the growth factor is too small.
487*
488 IF( grow.LE.smlnum )
489 $ GO TO 80
490*
491* G(j) = ( 1 + CNORM(j) )*G(j-1)
492*
493 xj = one + cnorm( j )
494 grow = grow / xj
495 70 CONTINUE
496 END IF
497 80 CONTINUE
498 END IF
499*
500 IF( ( grow*tscal ).GT.smlnum ) THEN
501*
502* Use the Level 2 BLAS solve if the reciprocal of the bound on
503* elements of X is not too small.
504*
505 CALL dtpsv( uplo, trans, diag, n, ap, x, 1 )
506 ELSE
507*
508* Use a Level 1 BLAS solve, scaling intermediate results.
509*
510 IF( xmax.GT.bignum ) THEN
511*
512* Scale X so that its components are less than or equal to
513* BIGNUM in absolute value.
514*
515 scale = bignum / xmax
516 CALL dscal( n, scale, x, 1 )
517 xmax = bignum
518 END IF
519*
520 IF( notran ) THEN
521*
522* Solve A * x = b
523*
524 ip = jfirst*( jfirst+1 ) / 2
525 DO 110 j = jfirst, jlast, jinc
526*
527* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
528*
529 xj = abs( x( j ) )
530 IF( nounit ) THEN
531 tjjs = ap( ip )*tscal
532 ELSE
533 tjjs = tscal
534 IF( tscal.EQ.one )
535 $ GO TO 100
536 END IF
537 tjj = abs( tjjs )
538 IF( tjj.GT.smlnum ) THEN
539*
540* abs(A(j,j)) > SMLNUM:
541*
542 IF( tjj.LT.one ) THEN
543 IF( xj.GT.tjj*bignum ) THEN
544*
545* Scale x by 1/b(j).
546*
547 rec = one / xj
548 CALL dscal( n, rec, x, 1 )
549 scale = scale*rec
550 xmax = xmax*rec
551 END IF
552 END IF
553 x( j ) = x( j ) / tjjs
554 xj = abs( x( j ) )
555 ELSE IF( tjj.GT.zero ) THEN
556*
557* 0 < abs(A(j,j)) <= SMLNUM:
558*
559 IF( xj.GT.tjj*bignum ) THEN
560*
561* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
562* to avoid overflow when dividing by A(j,j).
563*
564 rec = ( tjj*bignum ) / xj
565 IF( cnorm( j ).GT.one ) THEN
566*
567* Scale by 1/CNORM(j) to avoid overflow when
568* multiplying x(j) times column j.
569*
570 rec = rec / cnorm( j )
571 END IF
572 CALL dscal( n, rec, x, 1 )
573 scale = scale*rec
574 xmax = xmax*rec
575 END IF
576 x( j ) = x( j ) / tjjs
577 xj = abs( x( j ) )
578 ELSE
579*
580* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
581* scale = 0, and compute a solution to A*x = 0.
582*
583 DO 90 i = 1, n
584 x( i ) = zero
585 90 CONTINUE
586 x( j ) = one
587 xj = one
588 scale = zero
589 xmax = zero
590 END IF
591 100 CONTINUE
592*
593* Scale x if necessary to avoid overflow when adding a
594* multiple of column j of A.
595*
596 IF( xj.GT.one ) THEN
597 rec = one / xj
598 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
599*
600* Scale x by 1/(2*abs(x(j))).
601*
602 rec = rec*half
603 CALL dscal( n, rec, x, 1 )
604 scale = scale*rec
605 END IF
606 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
607*
608* Scale x by 1/2.
609*
610 CALL dscal( n, half, x, 1 )
611 scale = scale*half
612 END IF
613*
614 IF( upper ) THEN
615 IF( j.GT.1 ) THEN
616*
617* Compute the update
618* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
619*
620 CALL daxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,
621 $ 1 )
622 i = idamax( j-1, x, 1 )
623 xmax = abs( x( i ) )
624 END IF
625 ip = ip - j
626 ELSE
627 IF( j.LT.n ) THEN
628*
629* Compute the update
630* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
631*
632 CALL daxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1,
633 $ x( j+1 ), 1 )
634 i = j + idamax( n-j, x( j+1 ), 1 )
635 xmax = abs( x( i ) )
636 END IF
637 ip = ip + n - j + 1
638 END IF
639 110 CONTINUE
640*
641 ELSE
642*
643* Solve A**T * x = b
644*
645 ip = jfirst*( jfirst+1 ) / 2
646 jlen = 1
647 DO 160 j = jfirst, jlast, jinc
648*
649* Compute x(j) = b(j) - sum A(k,j)*x(k).
650* k<>j
651*
652 xj = abs( x( j ) )
653 uscal = tscal
654 rec = one / max( xmax, one )
655 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
656*
657* If x(j) could overflow, scale x by 1/(2*XMAX).
658*
659 rec = rec*half
660 IF( nounit ) THEN
661 tjjs = ap( ip )*tscal
662 ELSE
663 tjjs = tscal
664 END IF
665 tjj = abs( tjjs )
666 IF( tjj.GT.one ) THEN
667*
668* Divide by A(j,j) when scaling x if A(j,j) > 1.
669*
670 rec = min( one, rec*tjj )
671 uscal = uscal / tjjs
672 END IF
673 IF( rec.LT.one ) THEN
674 CALL dscal( n, rec, x, 1 )
675 scale = scale*rec
676 xmax = xmax*rec
677 END IF
678 END IF
679*
680 sumj = zero
681 IF( uscal.EQ.one ) THEN
682*
683* If the scaling needed for A in the dot product is 1,
684* call DDOT to perform the dot product.
685*
686 IF( upper ) THEN
687 sumj = ddot( j-1, ap( ip-j+1 ), 1, x, 1 )
688 ELSE IF( j.LT.n ) THEN
689 sumj = ddot( n-j, ap( ip+1 ), 1, x( j+1 ), 1 )
690 END IF
691 ELSE
692*
693* Otherwise, use in-line code for the dot product.
694*
695 IF( upper ) THEN
696 DO 120 i = 1, j - 1
697 sumj = sumj + ( ap( ip-j+i )*uscal )*x( i )
698 120 CONTINUE
699 ELSE IF( j.LT.n ) THEN
700 DO 130 i = 1, n - j
701 sumj = sumj + ( ap( ip+i )*uscal )*x( j+i )
702 130 CONTINUE
703 END IF
704 END IF
705*
706 IF( uscal.EQ.tscal ) THEN
707*
708* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
709* was not used to scale the dotproduct.
710*
711 x( j ) = x( j ) - sumj
712 xj = abs( x( j ) )
713 IF( nounit ) THEN
714*
715* Compute x(j) = x(j) / A(j,j), scaling if necessary.
716*
717 tjjs = ap( ip )*tscal
718 ELSE
719 tjjs = tscal
720 IF( tscal.EQ.one )
721 $ GO TO 150
722 END IF
723 tjj = abs( tjjs )
724 IF( tjj.GT.smlnum ) THEN
725*
726* abs(A(j,j)) > SMLNUM:
727*
728 IF( tjj.LT.one ) THEN
729 IF( xj.GT.tjj*bignum ) THEN
730*
731* Scale X by 1/abs(x(j)).
732*
733 rec = one / xj
734 CALL dscal( n, rec, x, 1 )
735 scale = scale*rec
736 xmax = xmax*rec
737 END IF
738 END IF
739 x( j ) = x( j ) / tjjs
740 ELSE IF( tjj.GT.zero ) THEN
741*
742* 0 < abs(A(j,j)) <= SMLNUM:
743*
744 IF( xj.GT.tjj*bignum ) THEN
745*
746* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
747*
748 rec = ( tjj*bignum ) / xj
749 CALL dscal( n, rec, x, 1 )
750 scale = scale*rec
751 xmax = xmax*rec
752 END IF
753 x( j ) = x( j ) / tjjs
754 ELSE
755*
756* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
757* scale = 0, and compute a solution to A**T*x = 0.
758*
759 DO 140 i = 1, n
760 x( i ) = zero
761 140 CONTINUE
762 x( j ) = one
763 scale = zero
764 xmax = zero
765 END IF
766 150 CONTINUE
767 ELSE
768*
769* Compute x(j) := x(j) / A(j,j) - sumj if the dot
770* product has already been divided by 1/A(j,j).
771*
772 x( j ) = x( j ) / tjjs - sumj
773 END IF
774 xmax = max( xmax, abs( x( j ) ) )
775 jlen = jlen + 1
776 ip = ip + jinc*jlen
777 160 CONTINUE
778 END IF
779 scale = scale / tscal
780 END IF
781*
782* Scale the column norms by 1/TSCAL for return.
783*
784 IF( tscal.NE.one ) THEN
785 CALL dscal( n, one / tscal, cnorm, 1 )
786 END IF
787*
788 RETURN
789*
790* End of DLATPS
791*
dtpsv
subroutine dtpsv(uplo, trans, diag, n, ap, x, incx)
DTPSV
Definition dtpsv.f:144

◆ dlatrd()

subroutine dlatrd ( character uplo,
integer n,
integer nb,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) e,
double precision, dimension( * ) tau,
double precision, dimension( ldw, * ) w,
integer ldw )

DLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.

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

Purpose:
!>
!> DLATRD reduces NB rows and columns of a real symmetric matrix A to
!> symmetric tridiagonal form by an orthogonal similarity
!> transformation Q**T * A * Q, and returns the matrices V and W which are
!> needed to apply the transformation to the unreduced part of A.
!>
!> If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
!> matrix, of which the upper triangle is supplied;
!> if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
!> matrix, of which the lower triangle is supplied.
!>
!> This is an auxiliary routine called by DSYTRD.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U': Upper triangular
!>          = 'L': Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.
!>
[in]NB
!>          NB is INTEGER
!>          The number of rows and columns to be reduced.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit:
!>          if UPLO = 'U', the last NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements above the diagonal
!>            with the array TAU, represent the orthogonal matrix Q as a
!>            product of elementary reflectors;
!>          if UPLO = 'L', the first NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements below the diagonal
!>            with the array TAU, represent the  orthogonal matrix Q as a
!>            product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= (1,N).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
!>          elements of the last NB columns of the reduced matrix;
!>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
!>          the first NB columns of the reduced matrix.
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N-1)
!>          The scalar factors of the elementary reflectors, stored in
!>          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
!>          See Further Details.
!>
[out]W
!>          W is DOUBLE PRECISION array, dimension (LDW,NB)
!>          The n-by-nb matrix W required to update the unreduced part
!>          of A.
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array W. LDW >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n) H(n-1) . . . H(n-nb+1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
!>  and tau in TAU(i-1).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!>  and tau in TAU(i).
!>
!>  The elements of the vectors v together form the n-by-nb matrix V
!>  which is needed, with W, to apply the transformation to the unreduced
!>  part of the matrix, using a symmetric rank-2k update of the form:
!>  A := A - V*W**T - W*V**T.
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5 and nb = 2:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  a   a   a   v4  v5 )              (  d                  )
!>    (      a   a   v4  v5 )              (  1   d              )
!>    (          a   1   v5 )              (  v1  1   a          )
!>    (              d   1  )              (  v1  v2  a   a      )
!>    (                  d  )              (  v1  v2  a   a   a  )
!>
!>  where d denotes a diagonal element of the reduced matrix, a denotes
!>  an element of the original matrix that is unchanged, and vi denotes
!>  an element of the vector defining H(i).
!>

Definition at line 197 of file dlatrd.f.

198*
199* -- LAPACK auxiliary routine --
200* -- LAPACK is a software package provided by Univ. of Tennessee, --
201* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202*
203* .. Scalar Arguments ..
204 CHARACTER UPLO
205 INTEGER LDA, LDW, N, NB
206* ..
207* .. Array Arguments ..
208 DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
209* ..
210*
211* =====================================================================
212*
213* .. Parameters ..
214 DOUBLE PRECISION ZERO, ONE, HALF
215 parameter( zero = 0.0d+0, one = 1.0d+0, half = 0.5d+0 )
216* ..
217* .. Local Scalars ..
218 INTEGER I, IW
219 DOUBLE PRECISION ALPHA
220* ..
221* .. External Subroutines ..
222 EXTERNAL daxpy, dgemv, dlarfg, dscal, dsymv
223* ..
224* .. External Functions ..
225 LOGICAL LSAME
226 DOUBLE PRECISION DDOT
227 EXTERNAL lsame, ddot
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC min
231* ..
232* .. Executable Statements ..
233*
234* Quick return if possible
235*
236 IF( n.LE.0 )
237 $ RETURN
238*
239 IF( lsame( uplo, 'U' ) ) THEN
240*
241* Reduce last NB columns of upper triangle
242*
243 DO 10 i = n, n - nb + 1, -1
244 iw = i - n + nb
245 IF( i.LT.n ) THEN
246*
247* Update A(1:i,i)
248*
249 CALL dgemv( 'No transpose', i, n-i, -one, a( 1, i+1 ),
250 $ lda, w( i, iw+1 ), ldw, one, a( 1, i ), 1 )
251 CALL dgemv( 'No transpose', i, n-i, -one, w( 1, iw+1 ),
252 $ ldw, a( i, i+1 ), lda, one, a( 1, i ), 1 )
253 END IF
254 IF( i.GT.1 ) THEN
255*
256* Generate elementary reflector H(i) to annihilate
257* A(1:i-2,i)
258*
259 CALL dlarfg( i-1, a( i-1, i ), a( 1, i ), 1, tau( i-1 ) )
260 e( i-1 ) = a( i-1, i )
261 a( i-1, i ) = one
262*
263* Compute W(1:i-1,i)
264*
265 CALL dsymv( 'Upper', i-1, one, a, lda, a( 1, i ), 1,
266 $ zero, w( 1, iw ), 1 )
267 IF( i.LT.n ) THEN
268 CALL dgemv( 'Transpose', i-1, n-i, one, w( 1, iw+1 ),
269 $ ldw, a( 1, i ), 1, zero, w( i+1, iw ), 1 )
270 CALL dgemv( 'No transpose', i-1, n-i, -one,
271 $ a( 1, i+1 ), lda, w( i+1, iw ), 1, one,
272 $ w( 1, iw ), 1 )
273 CALL dgemv( 'Transpose', i-1, n-i, one, a( 1, i+1 ),
274 $ lda, a( 1, i ), 1, zero, w( i+1, iw ), 1 )
275 CALL dgemv( 'No transpose', i-1, n-i, -one,
276 $ w( 1, iw+1 ), ldw, w( i+1, iw ), 1, one,
277 $ w( 1, iw ), 1 )
278 END IF
279 CALL dscal( i-1, tau( i-1 ), w( 1, iw ), 1 )
280 alpha = -half*tau( i-1 )*ddot( i-1, w( 1, iw ), 1,
281 $ a( 1, i ), 1 )
282 CALL daxpy( i-1, alpha, a( 1, i ), 1, w( 1, iw ), 1 )
283 END IF
284*
285 10 CONTINUE
286 ELSE
287*
288* Reduce first NB columns of lower triangle
289*
290 DO 20 i = 1, nb
291*
292* Update A(i:n,i)
293*
294 CALL dgemv( 'No transpose', n-i+1, i-1, -one, a( i, 1 ),
295 $ lda, w( i, 1 ), ldw, one, a( i, i ), 1 )
296 CALL dgemv( 'No transpose', n-i+1, i-1, -one, w( i, 1 ),
297 $ ldw, a( i, 1 ), lda, one, a( i, i ), 1 )
298 IF( i.LT.n ) THEN
299*
300* Generate elementary reflector H(i) to annihilate
301* A(i+2:n,i)
302*
303 CALL dlarfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1,
304 $ tau( i ) )
305 e( i ) = a( i+1, i )
306 a( i+1, i ) = one
307*
308* Compute W(i+1:n,i)
309*
310 CALL dsymv( 'Lower', n-i, one, a( i+1, i+1 ), lda,
311 $ a( i+1, i ), 1, zero, w( i+1, i ), 1 )
312 CALL dgemv( 'Transpose', n-i, i-1, one, w( i+1, 1 ), ldw,
313 $ a( i+1, i ), 1, zero, w( 1, i ), 1 )
314 CALL dgemv( 'No transpose', n-i, i-1, -one, a( i+1, 1 ),
315 $ lda, w( 1, i ), 1, one, w( i+1, i ), 1 )
316 CALL dgemv( 'Transpose', n-i, i-1, one, a( i+1, 1 ), lda,
317 $ a( i+1, i ), 1, zero, w( 1, i ), 1 )
318 CALL dgemv( 'No transpose', n-i, i-1, -one, w( i+1, 1 ),
319 $ ldw, w( 1, i ), 1, one, w( i+1, i ), 1 )
320 CALL dscal( n-i, tau( i ), w( i+1, i ), 1 )
321 alpha = -half*tau( i )*ddot( n-i, w( i+1, i ), 1,
322 $ a( i+1, i ), 1 )
323 CALL daxpy( n-i, alpha, a( i+1, i ), 1, w( i+1, i ), 1 )
324 END IF
325*
326 20 CONTINUE
327 END IF
328*
329 RETURN
330*
331* End of DLATRD
332*

◆ dlatrs()

subroutine dlatrs ( character uplo,
character trans,
character diag,
character normin,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) x,
double precision scale,
double precision, dimension( * ) cnorm,
integer info )

DLATRS solves a triangular system of equations with the scale factor set to prevent overflow.

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

Purpose:
!>
!> DLATRS solves one of the triangular systems
!>
!>    A *x = s*b  or  A**T *x = s*b
!>
!> with scaling to prevent overflow.  Here A is an upper or lower
!> triangular matrix, A**T denotes the transpose of A, x and b are
!> n-element vectors, and s is a scaling factor, usually less than
!> or equal to 1, chosen so that the components of x will be less than
!> the overflow threshold.  If the unscaled problem will not cause
!> overflow, the Level 2 BLAS routine DTRSV is called.  If the matrix A
!> is singular (A(j,j) = 0 for some j), then s is set to 0 and a
!> non-trivial solution to A*x = 0 is returned.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  Solve A * x = s*b  (No transpose)
!>          = 'T':  Solve A**T* x = s*b  (Transpose)
!>          = 'C':  Solve A**T* x = s*b  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]NORMIN
!>          NORMIN is CHARACTER*1
!>          Specifies whether CNORM has been set or not.
!>          = 'Y':  CNORM contains the column norms on entry
!>          = 'N':  CNORM is not set on entry.  On exit, the norms will
!>                  be computed and stored in CNORM.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max (1,N).
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b  or  A**T* x = s*b.
!>          If SCALE = 0, the matrix A is singular or badly scaled, and
!>          the vector x is an exact or approximate solution to A*x = 0.
!>
[in,out]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, DTRSV
!>  is called, otherwise, specific code is used which checks for possible
!>  overflow or divide-by-zero at every operation.
!>
!>  A columnwise scheme is used for solving A*x = b.  The basic algorithm
!>  if A is lower triangular is
!>
!>       x[1:n] := b[1:n]
!>       for j = 1, ..., n
!>            x(j) := x(j) / A(j,j)
!>            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
!>       end
!>
!>  Define bounds on the components of x after j iterations of the loop:
!>     M(j) = bound on x[1:j]
!>     G(j) = bound on x[j+1:n]
!>  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
!>
!>  Then for iteration j+1 we have
!>     M(j+1) <= G(j) / | A(j+1,j+1) |
!>     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
!>            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
!>
!>  where CNORM(j+1) is greater than or equal to the infinity-norm of
!>  column j+1 of A, not counting the diagonal.  Hence
!>
!>     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
!>                  1<=i<=j
!>  and
!>
!>     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
!>                                   1<=i< j
!>
!>  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
!>  reciprocal of the largest M(j), j=1,..,n, is larger than
!>  max(underflow, 1/overflow).
!>
!>  The bound on x(j) is also used to determine when a step in the
!>  columnwise method can be performed without fear of overflow.  If
!>  the computed bound is greater than a large constant, x is scaled to
!>  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
!>  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
!>
!>  Similarly, a row-wise scheme is used to solve A**T*x = b.  The basic
!>  algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j
!>       M(j) = bound on x(i), 1<=i<=j
!>
!>  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
!>  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
!>  Then the bound on x(j) is
!>
!>       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
!>
!>            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
!>                      1<=i<=j
!>
!>  and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 236 of file dlatrs.f.

238*
239* -- LAPACK auxiliary routine --
240* -- LAPACK is a software package provided by Univ. of Tennessee, --
241* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
242*
243* .. Scalar Arguments ..
244 CHARACTER DIAG, NORMIN, TRANS, UPLO
245 INTEGER INFO, LDA, N
246 DOUBLE PRECISION SCALE
247* ..
248* .. Array Arguments ..
249 DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * )
250* ..
251*
252* =====================================================================
253*
254* .. Parameters ..
255 DOUBLE PRECISION ZERO, HALF, ONE
256 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0 )
257* ..
258* .. Local Scalars ..
259 LOGICAL NOTRAN, NOUNIT, UPPER
260 INTEGER I, IMAX, J, JFIRST, JINC, JLAST
261 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
262 $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
263* ..
264* .. External Functions ..
265 LOGICAL LSAME
266 INTEGER IDAMAX
267 DOUBLE PRECISION DASUM, DDOT, DLAMCH
268 EXTERNAL lsame, idamax, dasum, ddot, dlamch
269* ..
270* .. External Subroutines ..
271 EXTERNAL daxpy, dscal, dtrsv, xerbla
272* ..
273* .. Intrinsic Functions ..
274 INTRINSIC abs, max, min
275* ..
276* .. Executable Statements ..
277*
278 info = 0
279 upper = lsame( uplo, 'U' )
280 notran = lsame( trans, 'N' )
281 nounit = lsame( diag, 'N' )
282*
283* Test the input parameters.
284*
285 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
286 info = -1
287 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
288 $ lsame( trans, 'C' ) ) THEN
289 info = -2
290 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
291 info = -3
292 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
293 $ lsame( normin, 'N' ) ) THEN
294 info = -4
295 ELSE IF( n.LT.0 ) THEN
296 info = -5
297 ELSE IF( lda.LT.max( 1, n ) ) THEN
298 info = -7
299 END IF
300 IF( info.NE.0 ) THEN
301 CALL xerbla( 'DLATRS', -info )
302 RETURN
303 END IF
304*
305* Quick return if possible
306*
307 IF( n.EQ.0 )
308 $ RETURN
309*
310* Determine machine dependent parameters to control overflow.
311*
312 smlnum = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
313 bignum = one / smlnum
314 scale = one
315*
316 IF( lsame( normin, 'N' ) ) THEN
317*
318* Compute the 1-norm of each column, not including the diagonal.
319*
320 IF( upper ) THEN
321*
322* A is upper triangular.
323*
324 DO 10 j = 1, n
325 cnorm( j ) = dasum( j-1, a( 1, j ), 1 )
326 10 CONTINUE
327 ELSE
328*
329* A is lower triangular.
330*
331 DO 20 j = 1, n - 1
332 cnorm( j ) = dasum( n-j, a( j+1, j ), 1 )
333 20 CONTINUE
334 cnorm( n ) = zero
335 END IF
336 END IF
337*
338* Scale the column norms by TSCAL if the maximum element in CNORM is
339* greater than BIGNUM.
340*
341 imax = idamax( n, cnorm, 1 )
342 tmax = cnorm( imax )
343 IF( tmax.LE.bignum ) THEN
344 tscal = one
345 ELSE
346 tscal = one / ( smlnum*tmax )
347 CALL dscal( n, tscal, cnorm, 1 )
348 END IF
349*
350* Compute a bound on the computed solution vector to see if the
351* Level 2 BLAS routine DTRSV can be used.
352*
353 j = idamax( n, x, 1 )
354 xmax = abs( x( j ) )
355 xbnd = xmax
356 IF( notran ) THEN
357*
358* Compute the growth in A * x = b.
359*
360 IF( upper ) THEN
361 jfirst = n
362 jlast = 1
363 jinc = -1
364 ELSE
365 jfirst = 1
366 jlast = n
367 jinc = 1
368 END IF
369*
370 IF( tscal.NE.one ) THEN
371 grow = zero
372 GO TO 50
373 END IF
374*
375 IF( nounit ) THEN
376*
377* A is non-unit triangular.
378*
379* Compute GROW = 1/G(j) and XBND = 1/M(j).
380* Initially, G(0) = max{x(i), i=1,...,n}.
381*
382 grow = one / max( xbnd, smlnum )
383 xbnd = grow
384 DO 30 j = jfirst, jlast, jinc
385*
386* Exit the loop if the growth factor is too small.
387*
388 IF( grow.LE.smlnum )
389 $ GO TO 50
390*
391* M(j) = G(j-1) / abs(A(j,j))
392*
393 tjj = abs( a( j, j ) )
394 xbnd = min( xbnd, min( one, tjj )*grow )
395 IF( tjj+cnorm( j ).GE.smlnum ) THEN
396*
397* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
398*
399 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
400 ELSE
401*
402* G(j) could overflow, set GROW to 0.
403*
404 grow = zero
405 END IF
406 30 CONTINUE
407 grow = xbnd
408 ELSE
409*
410* A is unit triangular.
411*
412* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
413*
414 grow = min( one, one / max( xbnd, smlnum ) )
415 DO 40 j = jfirst, jlast, jinc
416*
417* Exit the loop if the growth factor is too small.
418*
419 IF( grow.LE.smlnum )
420 $ GO TO 50
421*
422* G(j) = G(j-1)*( 1 + CNORM(j) )
423*
424 grow = grow*( one / ( one+cnorm( j ) ) )
425 40 CONTINUE
426 END IF
427 50 CONTINUE
428*
429 ELSE
430*
431* Compute the growth in A**T * x = b.
432*
433 IF( upper ) THEN
434 jfirst = 1
435 jlast = n
436 jinc = 1
437 ELSE
438 jfirst = n
439 jlast = 1
440 jinc = -1
441 END IF
442*
443 IF( tscal.NE.one ) THEN
444 grow = zero
445 GO TO 80
446 END IF
447*
448 IF( nounit ) THEN
449*
450* A is non-unit triangular.
451*
452* Compute GROW = 1/G(j) and XBND = 1/M(j).
453* Initially, M(0) = max{x(i), i=1,...,n}.
454*
455 grow = one / max( xbnd, smlnum )
456 xbnd = grow
457 DO 60 j = jfirst, jlast, jinc
458*
459* Exit the loop if the growth factor is too small.
460*
461 IF( grow.LE.smlnum )
462 $ GO TO 80
463*
464* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
465*
466 xj = one + cnorm( j )
467 grow = min( grow, xbnd / xj )
468*
469* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
470*
471 tjj = abs( a( j, j ) )
472 IF( xj.GT.tjj )
473 $ xbnd = xbnd*( tjj / xj )
474 60 CONTINUE
475 grow = min( grow, xbnd )
476 ELSE
477*
478* A is unit triangular.
479*
480* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
481*
482 grow = min( one, one / max( xbnd, smlnum ) )
483 DO 70 j = jfirst, jlast, jinc
484*
485* Exit the loop if the growth factor is too small.
486*
487 IF( grow.LE.smlnum )
488 $ GO TO 80
489*
490* G(j) = ( 1 + CNORM(j) )*G(j-1)
491*
492 xj = one + cnorm( j )
493 grow = grow / xj
494 70 CONTINUE
495 END IF
496 80 CONTINUE
497 END IF
498*
499 IF( ( grow*tscal ).GT.smlnum ) THEN
500*
501* Use the Level 2 BLAS solve if the reciprocal of the bound on
502* elements of X is not too small.
503*
504 CALL dtrsv( uplo, trans, diag, n, a, lda, x, 1 )
505 ELSE
506*
507* Use a Level 1 BLAS solve, scaling intermediate results.
508*
509 IF( xmax.GT.bignum ) THEN
510*
511* Scale X so that its components are less than or equal to
512* BIGNUM in absolute value.
513*
514 scale = bignum / xmax
515 CALL dscal( n, scale, x, 1 )
516 xmax = bignum
517 END IF
518*
519 IF( notran ) THEN
520*
521* Solve A * x = b
522*
523 DO 110 j = jfirst, jlast, jinc
524*
525* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
526*
527 xj = abs( x( j ) )
528 IF( nounit ) THEN
529 tjjs = a( j, j )*tscal
530 ELSE
531 tjjs = tscal
532 IF( tscal.EQ.one )
533 $ GO TO 100
534 END IF
535 tjj = abs( tjjs )
536 IF( tjj.GT.smlnum ) THEN
537*
538* abs(A(j,j)) > SMLNUM:
539*
540 IF( tjj.LT.one ) THEN
541 IF( xj.GT.tjj*bignum ) THEN
542*
543* Scale x by 1/b(j).
544*
545 rec = one / xj
546 CALL dscal( n, rec, x, 1 )
547 scale = scale*rec
548 xmax = xmax*rec
549 END IF
550 END IF
551 x( j ) = x( j ) / tjjs
552 xj = abs( x( j ) )
553 ELSE IF( tjj.GT.zero ) THEN
554*
555* 0 < abs(A(j,j)) <= SMLNUM:
556*
557 IF( xj.GT.tjj*bignum ) THEN
558*
559* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
560* to avoid overflow when dividing by A(j,j).
561*
562 rec = ( tjj*bignum ) / xj
563 IF( cnorm( j ).GT.one ) THEN
564*
565* Scale by 1/CNORM(j) to avoid overflow when
566* multiplying x(j) times column j.
567*
568 rec = rec / cnorm( j )
569 END IF
570 CALL dscal( n, rec, x, 1 )
571 scale = scale*rec
572 xmax = xmax*rec
573 END IF
574 x( j ) = x( j ) / tjjs
575 xj = abs( x( j ) )
576 ELSE
577*
578* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
579* scale = 0, and compute a solution to A*x = 0.
580*
581 DO 90 i = 1, n
582 x( i ) = zero
583 90 CONTINUE
584 x( j ) = one
585 xj = one
586 scale = zero
587 xmax = zero
588 END IF
589 100 CONTINUE
590*
591* Scale x if necessary to avoid overflow when adding a
592* multiple of column j of A.
593*
594 IF( xj.GT.one ) THEN
595 rec = one / xj
596 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
597*
598* Scale x by 1/(2*abs(x(j))).
599*
600 rec = rec*half
601 CALL dscal( n, rec, x, 1 )
602 scale = scale*rec
603 END IF
604 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
605*
606* Scale x by 1/2.
607*
608 CALL dscal( n, half, x, 1 )
609 scale = scale*half
610 END IF
611*
612 IF( upper ) THEN
613 IF( j.GT.1 ) THEN
614*
615* Compute the update
616* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
617*
618 CALL daxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,
619 $ 1 )
620 i = idamax( j-1, x, 1 )
621 xmax = abs( x( i ) )
622 END IF
623 ELSE
624 IF( j.LT.n ) THEN
625*
626* Compute the update
627* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
628*
629 CALL daxpy( n-j, -x( j )*tscal, a( j+1, j ), 1,
630 $ x( j+1 ), 1 )
631 i = j + idamax( n-j, x( j+1 ), 1 )
632 xmax = abs( x( i ) )
633 END IF
634 END IF
635 110 CONTINUE
636*
637 ELSE
638*
639* Solve A**T * x = b
640*
641 DO 160 j = jfirst, jlast, jinc
642*
643* Compute x(j) = b(j) - sum A(k,j)*x(k).
644* k<>j
645*
646 xj = abs( x( j ) )
647 uscal = tscal
648 rec = one / max( xmax, one )
649 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
650*
651* If x(j) could overflow, scale x by 1/(2*XMAX).
652*
653 rec = rec*half
654 IF( nounit ) THEN
655 tjjs = a( j, j )*tscal
656 ELSE
657 tjjs = tscal
658 END IF
659 tjj = abs( tjjs )
660 IF( tjj.GT.one ) THEN
661*
662* Divide by A(j,j) when scaling x if A(j,j) > 1.
663*
664 rec = min( one, rec*tjj )
665 uscal = uscal / tjjs
666 END IF
667 IF( rec.LT.one ) THEN
668 CALL dscal( n, rec, x, 1 )
669 scale = scale*rec
670 xmax = xmax*rec
671 END IF
672 END IF
673*
674 sumj = zero
675 IF( uscal.EQ.one ) THEN
676*
677* If the scaling needed for A in the dot product is 1,
678* call DDOT to perform the dot product.
679*
680 IF( upper ) THEN
681 sumj = ddot( j-1, a( 1, j ), 1, x, 1 )
682 ELSE IF( j.LT.n ) THEN
683 sumj = ddot( n-j, a( j+1, j ), 1, x( j+1 ), 1 )
684 END IF
685 ELSE
686*
687* Otherwise, use in-line code for the dot product.
688*
689 IF( upper ) THEN
690 DO 120 i = 1, j - 1
691 sumj = sumj + ( a( i, j )*uscal )*x( i )
692 120 CONTINUE
693 ELSE IF( j.LT.n ) THEN
694 DO 130 i = j + 1, n
695 sumj = sumj + ( a( i, j )*uscal )*x( i )
696 130 CONTINUE
697 END IF
698 END IF
699*
700 IF( uscal.EQ.tscal ) THEN
701*
702* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
703* was not used to scale the dotproduct.
704*
705 x( j ) = x( j ) - sumj
706 xj = abs( x( j ) )
707 IF( nounit ) THEN
708 tjjs = a( j, j )*tscal
709 ELSE
710 tjjs = tscal
711 IF( tscal.EQ.one )
712 $ GO TO 150
713 END IF
714*
715* Compute x(j) = x(j) / A(j,j), scaling if necessary.
716*
717 tjj = abs( tjjs )
718 IF( tjj.GT.smlnum ) THEN
719*
720* abs(A(j,j)) > SMLNUM:
721*
722 IF( tjj.LT.one ) THEN
723 IF( xj.GT.tjj*bignum ) THEN
724*
725* Scale X by 1/abs(x(j)).
726*
727 rec = one / xj
728 CALL dscal( n, rec, x, 1 )
729 scale = scale*rec
730 xmax = xmax*rec
731 END IF
732 END IF
733 x( j ) = x( j ) / tjjs
734 ELSE IF( tjj.GT.zero ) THEN
735*
736* 0 < abs(A(j,j)) <= SMLNUM:
737*
738 IF( xj.GT.tjj*bignum ) THEN
739*
740* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
741*
742 rec = ( tjj*bignum ) / xj
743 CALL dscal( n, rec, x, 1 )
744 scale = scale*rec
745 xmax = xmax*rec
746 END IF
747 x( j ) = x( j ) / tjjs
748 ELSE
749*
750* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
751* scale = 0, and compute a solution to A**T*x = 0.
752*
753 DO 140 i = 1, n
754 x( i ) = zero
755 140 CONTINUE
756 x( j ) = one
757 scale = zero
758 xmax = zero
759 END IF
760 150 CONTINUE
761 ELSE
762*
763* Compute x(j) := x(j) / A(j,j) - sumj if the dot
764* product has already been divided by 1/A(j,j).
765*
766 x( j ) = x( j ) / tjjs - sumj
767 END IF
768 xmax = max( xmax, abs( x( j ) ) )
769 160 CONTINUE
770 END IF
771 scale = scale / tscal
772 END IF
773*
774* Scale the column norms by 1/TSCAL for return.
775*
776 IF( tscal.NE.one ) THEN
777 CALL dscal( n, one / tscal, cnorm, 1 )
778 END IF
779*
780 RETURN
781*
782* End of DLATRS
783*
dtrsv
subroutine dtrsv(uplo, trans, diag, n, a, lda, x, incx)
DTRSV
Definition dtrsv.f:143

◆ dlauu2()

subroutine dlauu2 ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer info )

DLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).

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

Purpose:
!>
!> DLAUU2 computes the product U * U**T or L**T * L, where the triangular
!> factor U or L is stored in the upper or lower triangular part of
!> the array A.
!>
!> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!> overwriting the factor U in A.
!> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!> overwriting the factor L in A.
!>
!> This is the unblocked form of the algorithm, calling Level 2 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the triangular factor stored in the array A
!>          is upper or lower triangular:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the triangular factor U or L.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the triangular factor U or L.
!>          On exit, if UPLO = 'U', the upper triangle of A is
!>          overwritten with the upper triangle of the product U * U**T;
!>          if UPLO = 'L', the lower triangle of A is overwritten with
!>          the lower triangle of the product L**T * L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file dlauu2.f.

102*
103* -- LAPACK auxiliary routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 CHARACTER UPLO
109 INTEGER INFO, LDA, N
110* ..
111* .. Array Arguments ..
112 DOUBLE PRECISION A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ONE
119 parameter( one = 1.0d+0 )
120* ..
121* .. Local Scalars ..
122 LOGICAL UPPER
123 INTEGER I
124 DOUBLE PRECISION AII
125* ..
126* .. External Functions ..
127 LOGICAL LSAME
128 DOUBLE PRECISION DDOT
129 EXTERNAL lsame, ddot
130* ..
131* .. External Subroutines ..
132 EXTERNAL dgemv, dscal, xerbla
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC max
136* ..
137* .. Executable Statements ..
138*
139* Test the input parameters.
140*
141 info = 0
142 upper = lsame( uplo, 'U' )
143 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
144 info = -1
145 ELSE IF( n.LT.0 ) THEN
146 info = -2
147 ELSE IF( lda.LT.max( 1, n ) ) THEN
148 info = -4
149 END IF
150 IF( info.NE.0 ) THEN
151 CALL xerbla( 'DLAUU2', -info )
152 RETURN
153 END IF
154*
155* Quick return if possible
156*
157 IF( n.EQ.0 )
158 $ RETURN
159*
160 IF( upper ) THEN
161*
162* Compute the product U * U**T.
163*
164 DO 10 i = 1, n
165 aii = a( i, i )
166 IF( i.LT.n ) THEN
167 a( i, i ) = ddot( n-i+1, a( i, i ), lda, a( i, i ), lda )
168 CALL dgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
169 $ lda, a( i, i+1 ), lda, aii, a( 1, i ), 1 )
170 ELSE
171 CALL dscal( i, aii, a( 1, i ), 1 )
172 END IF
173 10 CONTINUE
174*
175 ELSE
176*
177* Compute the product L**T * L.
178*
179 DO 20 i = 1, n
180 aii = a( i, i )
181 IF( i.LT.n ) THEN
182 a( i, i ) = ddot( n-i+1, a( i, i ), 1, a( i, i ), 1 )
183 CALL dgemv( 'Transpose', n-i, i-1, one, a( i+1, 1 ), lda,
184 $ a( i+1, i ), 1, aii, a( i, 1 ), lda )
185 ELSE
186 CALL dscal( i, aii, a( i, 1 ), lda )
187 END IF
188 20 CONTINUE
189 END IF
190*
191 RETURN
192*
193* End of DLAUU2
194*

◆ dlauum()

subroutine dlauum ( character uplo,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
integer info )

DLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).

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

Purpose:
!>
!> DLAUUM computes the product U * U**T or L**T * L, where the triangular
!> factor U or L is stored in the upper or lower triangular part of
!> the array A.
!>
!> If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
!> overwriting the factor U in A.
!> If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
!> overwriting the factor L in A.
!>
!> This is the blocked form of the algorithm, calling Level 3 BLAS.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the triangular factor stored in the array A
!>          is upper or lower triangular:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the triangular factor U or L.  N >= 0.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the triangular factor U or L.
!>          On exit, if UPLO = 'U', the upper triangle of A is
!>          overwritten with the upper triangle of the product U * U**T;
!>          if UPLO = 'L', the lower triangle of A is overwritten with
!>          the lower triangle of the product L**T * L.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file dlauum.f.

102*
103* -- LAPACK auxiliary routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 CHARACTER UPLO
109 INTEGER INFO, LDA, N
110* ..
111* .. Array Arguments ..
112 DOUBLE PRECISION A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ONE
119 parameter( one = 1.0d+0 )
120* ..
121* .. Local Scalars ..
122 LOGICAL UPPER
123 INTEGER I, IB, NB
124* ..
125* .. External Functions ..
126 LOGICAL LSAME
127 INTEGER ILAENV
128 EXTERNAL lsame, ilaenv
129* ..
130* .. External Subroutines ..
131 EXTERNAL dgemm, dlauu2, dsyrk, dtrmm, xerbla
132* ..
133* .. Intrinsic Functions ..
134 INTRINSIC max, min
135* ..
136* .. Executable Statements ..
137*
138* Test the input parameters.
139*
140 info = 0
141 upper = lsame( uplo, 'U' )
142 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
143 info = -1
144 ELSE IF( n.LT.0 ) THEN
145 info = -2
146 ELSE IF( lda.LT.max( 1, n ) ) THEN
147 info = -4
148 END IF
149 IF( info.NE.0 ) THEN
150 CALL xerbla( 'DLAUUM', -info )
151 RETURN
152 END IF
153*
154* Quick return if possible
155*
156 IF( n.EQ.0 )
157 $ RETURN
158*
159* Determine the block size for this environment.
160*
161 nb = ilaenv( 1, 'DLAUUM', uplo, n, -1, -1, -1 )
162*
163 IF( nb.LE.1 .OR. nb.GE.n ) THEN
164*
165* Use unblocked code
166*
167 CALL dlauu2( uplo, n, a, lda, info )
168 ELSE
169*
170* Use blocked code
171*
172 IF( upper ) THEN
173*
174* Compute the product U * U**T.
175*
176 DO 10 i = 1, n, nb
177 ib = min( nb, n-i+1 )
178 CALL dtrmm( 'Right', 'Upper', 'Transpose', 'Non-unit',
179 $ i-1, ib, one, a( i, i ), lda, a( 1, i ),
180 $ lda )
181 CALL dlauu2( 'Upper', ib, a( i, i ), lda, info )
182 IF( i+ib.LE.n ) THEN
183 CALL dgemm( 'No transpose', 'Transpose', i-1, ib,
184 $ n-i-ib+1, one, a( 1, i+ib ), lda,
185 $ a( i, i+ib ), lda, one, a( 1, i ), lda )
186 CALL dsyrk( 'Upper', 'No transpose', ib, n-i-ib+1,
187 $ one, a( i, i+ib ), lda, one, a( i, i ),
188 $ lda )
189 END IF
190 10 CONTINUE
191 ELSE
192*
193* Compute the product L**T * L.
194*
195 DO 20 i = 1, n, nb
196 ib = min( nb, n-i+1 )
197 CALL dtrmm( 'Left', 'Lower', 'Transpose', 'Non-unit', ib,
198 $ i-1, one, a( i, i ), lda, a( i, 1 ), lda )
199 CALL dlauu2( 'Lower', ib, a( i, i ), lda, info )
200 IF( i+ib.LE.n ) THEN
201 CALL dgemm( 'Transpose', 'No transpose', ib, i-1,
202 $ n-i-ib+1, one, a( i+ib, i ), lda,
203 $ a( i+ib, 1 ), lda, one, a( i, 1 ), lda )
204 CALL dsyrk( 'Lower', 'Transpose', ib, n-i-ib+1, one,
205 $ a( i+ib, i ), lda, one, a( i, i ), lda )
206 END IF
207 20 CONTINUE
208 END IF
209 END IF
210*
211 RETURN
212*
213* End of DLAUUM
214*
dlauu2
subroutine dlauu2(uplo, n, a, lda, info)
DLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblock...
Definition dlauu2.f:102
dsyrk
subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
DSYRK
Definition dsyrk.f:169

◆ drscl()

subroutine drscl ( integer n,
double precision sa,
double precision, dimension( * ) sx,
integer incx )

DRSCL multiplies a vector by the reciprocal of a real scalar.

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

Purpose:
!>
!> DRSCL multiplies an n-element real vector x by the real scalar 1/a.
!> This is done without overflow or underflow as long as
!> the final result x/a does not overflow or underflow.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of components of the vector x.
!>
[in]SA
!>          SA is DOUBLE PRECISION
!>          The scalar a which is used to divide each component of x.
!>          SA must be >= 0, or the subroutine will divide by zero.
!>
[in,out]SX
!>          SX is DOUBLE PRECISION array, dimension
!>                         (1+(N-1)*abs(INCX))
!>          The n-element vector x.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between successive values of the vector SX.
!>          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 83 of file drscl.f.

84*
85* -- LAPACK auxiliary routine --
86* -- LAPACK is a software package provided by Univ. of Tennessee, --
87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88*
89* .. Scalar Arguments ..
90 INTEGER INCX, N
91 DOUBLE PRECISION SA
92* ..
93* .. Array Arguments ..
94 DOUBLE PRECISION SX( * )
95* ..
96*
97* =====================================================================
98*
99* .. Parameters ..
100 DOUBLE PRECISION ONE, ZERO
101 parameter( one = 1.0d+0, zero = 0.0d+0 )
102* ..
103* .. Local Scalars ..
104 LOGICAL DONE
105 DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
106* ..
107* .. External Functions ..
108 DOUBLE PRECISION DLAMCH
109 EXTERNAL dlamch
110* ..
111* .. External Subroutines ..
112 EXTERNAL dscal, dlabad
113* ..
114* .. Intrinsic Functions ..
115 INTRINSIC abs
116* ..
117* .. Executable Statements ..
118*
119* Quick return if possible
120*
121 IF( n.LE.0 )
122 $ RETURN
123*
124* Get machine parameters
125*
126 smlnum = dlamch( 'S' )
127 bignum = one / smlnum
128 CALL dlabad( smlnum, bignum )
129*
130* Initialize the denominator to SA and the numerator to 1.
131*
132 cden = sa
133 cnum = one
134*
135 10 CONTINUE
136 cden1 = cden*smlnum
137 cnum1 = cnum / bignum
138 IF( abs( cden1 ).GT.abs( cnum ) .AND. cnum.NE.zero ) THEN
139*
140* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
141*
142 mul = smlnum
143 done = .false.
144 cden = cden1
145 ELSE IF( abs( cnum1 ).GT.abs( cden ) ) THEN
146*
147* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
148*
149 mul = bignum
150 done = .false.
151 cnum = cnum1
152 ELSE
153*
154* Multiply X by CNUM / CDEN and return.
155*
156 mul = cnum / cden
157 done = .true.
158 END IF
159*
160* Scale the vector X by MUL
161*
162 CALL dscal( n, mul, sx, incx )
163*
164 IF( .NOT.done )
165 $ GO TO 10
166*
167 RETURN
168*
169* End of DRSCL
170*

◆ dtprfb()

subroutine dtprfb ( character side,
character trans,
character direct,
character storev,
integer m,
integer n,
integer k,
integer l,
double precision, dimension( ldv, * ) v,
integer ldv,
double precision, dimension( ldt, * ) t,
integer ldt,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( ldwork, * ) work,
integer ldwork )

DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks.

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

Purpose:
!>
!> DTPRFB applies a real  block reflector H or its
!> transpose H**T to a real matrix C, which is composed of two
!> blocks A and B, either from the left or right.
!>
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          = 'L': apply H or H**T from the Left
!>          = 'R': apply H or H**T from the Right
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N': apply H (No transpose)
!>          = 'T': apply H**T (Transpose)
!>
[in]DIRECT
!>          DIRECT is CHARACTER*1
!>          Indicates how H is formed from a product of elementary
!>          reflectors
!>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
!>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
!>
[in]STOREV
!>          STOREV is CHARACTER*1
!>          Indicates how the vectors which define the elementary
!>          reflectors are stored:
!>          = 'C': Columns
!>          = 'R': Rows
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix B.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix B.
!>          N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The order of the matrix T, i.e. the number of elementary
!>          reflectors whose product defines the block reflector.
!>          K >= 0.
!>
[in]L
!>          L is INTEGER
!>          The order of the trapezoidal part of V.
!>          K >= L >= 0.  See Further Details.
!>
[in]V
!>          V is DOUBLE PRECISION array, dimension
!>                                (LDV,K) if STOREV = 'C'
!>                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
!>                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
!>          The pentagonal matrix V, which contains the elementary reflectors
!>          H(1), H(2), ..., H(K).  See Further Details.
!>
[in]LDV
!>          LDV is INTEGER
!>          The leading dimension of the array V.
!>          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
!>          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
!>          if STOREV = 'R', LDV >= K.
!>
[in]T
!>          T is DOUBLE PRECISION array, dimension (LDT,K)
!>          The triangular K-by-K matrix T in the representation of the
!>          block reflector.
!>
[in]LDT
!>          LDT is INTEGER
!>          The leading dimension of the array T.
!>          LDT >= K.
!>
[in,out]A
!>          A is DOUBLE PRECISION array, dimension
!>          (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R'
!>          On entry, the K-by-N or M-by-K matrix A.
!>          On exit, A is overwritten by the corresponding block of
!>          H*C or H**T*C or C*H or C*H**T.  See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,K);
!>          If SIDE = 'R', LDA >= max(1,M).
!>
[in,out]B
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!>          On entry, the M-by-N matrix B.
!>          On exit, B is overwritten by the corresponding block of
!>          H*C or H**T*C or C*H or C*H**T.  See Further Details.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>          LDB >= max(1,M).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>          (LDWORK,N) if SIDE = 'L',
!>          (LDWORK,K) if SIDE = 'R'.
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.
!>          If SIDE = 'L', LDWORK >= K;
!>          if SIDE = 'R', LDWORK >= M.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  The matrix C is a composite matrix formed from blocks A and B.
!>  The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K,
!>  and if SIDE = 'L', A is of size K-by-N.
!>
!>  If SIDE = 'R' and DIRECT = 'F', C = [A B].
!>
!>  If SIDE = 'L' and DIRECT = 'F', C = [A]
!>                                      [B].
!>
!>  If SIDE = 'R' and DIRECT = 'B', C = [B A].
!>
!>  If SIDE = 'L' and DIRECT = 'B', C = [B]
!>                                      [A].
!>
!>  The pentagonal matrix V is composed of a rectangular block V1 and a
!>  trapezoidal block V2.  The size of the trapezoidal block is determined by
!>  the parameter L, where 0<=L<=K.  If L=K, the V2 block of V is triangular;
!>  if L=0, there is no trapezoidal block, thus V = V1 is rectangular.
!>
!>  If DIRECT = 'F' and STOREV = 'C':  V = [V1]
!>                                         [V2]
!>     - V2 is upper trapezoidal (first L rows of K-by-K upper triangular)
!>
!>  If DIRECT = 'F' and STOREV = 'R':  V = [V1 V2]
!>
!>     - V2 is lower trapezoidal (first L columns of K-by-K lower triangular)
!>
!>  If DIRECT = 'B' and STOREV = 'C':  V = [V2]
!>                                         [V1]
!>     - V2 is lower trapezoidal (last L rows of K-by-K lower triangular)
!>
!>  If DIRECT = 'B' and STOREV = 'R':  V = [V2 V1]
!>
!>     - V2 is upper trapezoidal (last L columns of K-by-K upper triangular)
!>
!>  If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K.
!>
!>  If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K.
!>
!>  If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L.
!>
!>  If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L.
!>

Definition at line 249 of file dtprfb.f.

251*
252* -- LAPACK auxiliary routine --
253* -- LAPACK is a software package provided by Univ. of Tennessee, --
254* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
255*
256* .. Scalar Arguments ..
257 CHARACTER DIRECT, SIDE, STOREV, TRANS
258 INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N
259* ..
260* .. Array Arguments ..
261 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ),
262 $ V( LDV, * ), WORK( LDWORK, * )
263* ..
264*
265* ==========================================================================
266*
267* .. Parameters ..
268 DOUBLE PRECISION ONE, ZERO
269 parameter( one = 1.0, zero = 0.0 )
270* ..
271* .. Local Scalars ..
272 INTEGER I, J, MP, NP, KP
273 LOGICAL LEFT, FORWARD, COLUMN, RIGHT, BACKWARD, ROW
274* ..
275* .. External Functions ..
276 LOGICAL LSAME
277 EXTERNAL lsame
278* ..
279* .. External Subroutines ..
280 EXTERNAL dgemm, dtrmm
281* ..
282* .. Executable Statements ..
283*
284* Quick return if possible
285*
286 IF( m.LE.0 .OR. n.LE.0 .OR. k.LE.0 .OR. l.LT.0 ) RETURN
287*
288 IF( lsame( storev, 'C' ) ) THEN
289 column = .true.
290 row = .false.
291 ELSE IF ( lsame( storev, 'R' ) ) THEN
292 column = .false.
293 row = .true.
294 ELSE
295 column = .false.
296 row = .false.
297 END IF
298*
299 IF( lsame( side, 'L' ) ) THEN
300 left = .true.
301 right = .false.
302 ELSE IF( lsame( side, 'R' ) ) THEN
303 left = .false.
304 right = .true.
305 ELSE
306 left = .false.
307 right = .false.
308 END IF
309*
310 IF( lsame( direct, 'F' ) ) THEN
311 forward = .true.
312 backward = .false.
313 ELSE IF( lsame( direct, 'B' ) ) THEN
314 forward = .false.
315 backward = .true.
316 ELSE
317 forward = .false.
318 backward = .false.
319 END IF
320*
321* ---------------------------------------------------------------------------
322*
323 IF( column .AND. forward .AND. left ) THEN
324*
325* ---------------------------------------------------------------------------
326*
327* Let W = [ I ] (K-by-K)
328* [ V ] (M-by-K)
329*
330* Form H C or H**T C where C = [ A ] (K-by-N)
331* [ B ] (M-by-N)
332*
333* H = I - W T W**T or H**T = I - W T**T W**T
334*
335* A = A - T (A + V**T B) or A = A - T**T (A + V**T B)
336* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B)
337*
338* ---------------------------------------------------------------------------
339*
340 mp = min( m-l+1, m )
341 kp = min( l+1, k )
342*
343 DO j = 1, n
344 DO i = 1, l
345 work( i, j ) = b( m-l+i, j )
346 END DO
347 END DO
348 CALL dtrmm( 'L', 'U', 'T', 'N', l, n, one, v( mp, 1 ), ldv,
349 $ work, ldwork )
350 CALL dgemm( 'T', 'N', l, n, m-l, one, v, ldv, b, ldb,
351 $ one, work, ldwork )
352 CALL dgemm( 'T', 'N', k-l, n, m, one, v( 1, kp ), ldv,
353 $ b, ldb, zero, work( kp, 1 ), ldwork )
354*
355 DO j = 1, n
356 DO i = 1, k
357 work( i, j ) = work( i, j ) + a( i, j )
358 END DO
359 END DO
360*
361 CALL dtrmm( 'L', 'U', trans, 'N', k, n, one, t, ldt,
362 $ work, ldwork )
363*
364 DO j = 1, n
365 DO i = 1, k
366 a( i, j ) = a( i, j ) - work( i, j )
367 END DO
368 END DO
369*
370 CALL dgemm( 'N', 'N', m-l, n, k, -one, v, ldv, work, ldwork,
371 $ one, b, ldb )
372 CALL dgemm( 'N', 'N', l, n, k-l, -one, v( mp, kp ), ldv,
373 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
374 CALL dtrmm( 'L', 'U', 'N', 'N', l, n, one, v( mp, 1 ), ldv,
375 $ work, ldwork )
376 DO j = 1, n
377 DO i = 1, l
378 b( m-l+i, j ) = b( m-l+i, j ) - work( i, j )
379 END DO
380 END DO
381*
382* ---------------------------------------------------------------------------
383*
384 ELSE IF( column .AND. forward .AND. right ) THEN
385*
386* ---------------------------------------------------------------------------
387*
388* Let W = [ I ] (K-by-K)
389* [ V ] (N-by-K)
390*
391* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N)
392*
393* H = I - W T W**T or H**T = I - W T**T W**T
394*
395* A = A - (A + B V) T or A = A - (A + B V) T**T
396* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T
397*
398* ---------------------------------------------------------------------------
399*
400 np = min( n-l+1, n )
401 kp = min( l+1, k )
402*
403 DO j = 1, l
404 DO i = 1, m
405 work( i, j ) = b( i, n-l+j )
406 END DO
407 END DO
408 CALL dtrmm( 'R', 'U', 'N', 'N', m, l, one, v( np, 1 ), ldv,
409 $ work, ldwork )
410 CALL dgemm( 'N', 'N', m, l, n-l, one, b, ldb,
411 $ v, ldv, one, work, ldwork )
412 CALL dgemm( 'N', 'N', m, k-l, n, one, b, ldb,
413 $ v( 1, kp ), ldv, zero, work( 1, kp ), ldwork )
414*
415 DO j = 1, k
416 DO i = 1, m
417 work( i, j ) = work( i, j ) + a( i, j )
418 END DO
419 END DO
420*
421 CALL dtrmm( 'R', 'U', trans, 'N', m, k, one, t, ldt,
422 $ work, ldwork )
423*
424 DO j = 1, k
425 DO i = 1, m
426 a( i, j ) = a( i, j ) - work( i, j )
427 END DO
428 END DO
429*
430 CALL dgemm( 'N', 'T', m, n-l, k, -one, work, ldwork,
431 $ v, ldv, one, b, ldb )
432 CALL dgemm( 'N', 'T', m, l, k-l, -one, work( 1, kp ), ldwork,
433 $ v( np, kp ), ldv, one, b( 1, np ), ldb )
434 CALL dtrmm( 'R', 'U', 'T', 'N', m, l, one, v( np, 1 ), ldv,
435 $ work, ldwork )
436 DO j = 1, l
437 DO i = 1, m
438 b( i, n-l+j ) = b( i, n-l+j ) - work( i, j )
439 END DO
440 END DO
441*
442* ---------------------------------------------------------------------------
443*
444 ELSE IF( column .AND. backward .AND. left ) THEN
445*
446* ---------------------------------------------------------------------------
447*
448* Let W = [ V ] (M-by-K)
449* [ I ] (K-by-K)
450*
451* Form H C or H**T C where C = [ B ] (M-by-N)
452* [ A ] (K-by-N)
453*
454* H = I - W T W**T or H**T = I - W T**T W**T
455*
456* A = A - T (A + V**T B) or A = A - T**T (A + V**T B)
457* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B)
458*
459* ---------------------------------------------------------------------------
460*
461 mp = min( l+1, m )
462 kp = min( k-l+1, k )
463*
464 DO j = 1, n
465 DO i = 1, l
466 work( k-l+i, j ) = b( i, j )
467 END DO
468 END DO
469*
470 CALL dtrmm( 'L', 'L', 'T', 'N', l, n, one, v( 1, kp ), ldv,
471 $ work( kp, 1 ), ldwork )
472 CALL dgemm( 'T', 'N', l, n, m-l, one, v( mp, kp ), ldv,
473 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
474 CALL dgemm( 'T', 'N', k-l, n, m, one, v, ldv,
475 $ b, ldb, zero, work, ldwork )
476*
477 DO j = 1, n
478 DO i = 1, k
479 work( i, j ) = work( i, j ) + a( i, j )
480 END DO
481 END DO
482*
483 CALL dtrmm( 'L', 'L', trans, 'N', k, n, one, t, ldt,
484 $ work, ldwork )
485*
486 DO j = 1, n
487 DO i = 1, k
488 a( i, j ) = a( i, j ) - work( i, j )
489 END DO
490 END DO
491*
492 CALL dgemm( 'N', 'N', m-l, n, k, -one, v( mp, 1 ), ldv,
493 $ work, ldwork, one, b( mp, 1 ), ldb )
494 CALL dgemm( 'N', 'N', l, n, k-l, -one, v, ldv,
495 $ work, ldwork, one, b, ldb )
496 CALL dtrmm( 'L', 'L', 'N', 'N', l, n, one, v( 1, kp ), ldv,
497 $ work( kp, 1 ), ldwork )
498 DO j = 1, n
499 DO i = 1, l
500 b( i, j ) = b( i, j ) - work( k-l+i, j )
501 END DO
502 END DO
503*
504* ---------------------------------------------------------------------------
505*
506 ELSE IF( column .AND. backward .AND. right ) THEN
507*
508* ---------------------------------------------------------------------------
509*
510* Let W = [ V ] (N-by-K)
511* [ I ] (K-by-K)
512*
513* Form C H or C H**T where C = [ B A ] (B is M-by-N, A is M-by-K)
514*
515* H = I - W T W**T or H**T = I - W T**T W**T
516*
517* A = A - (A + B V) T or A = A - (A + B V) T**T
518* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T
519*
520* ---------------------------------------------------------------------------
521*
522 np = min( l+1, n )
523 kp = min( k-l+1, k )
524*
525 DO j = 1, l
526 DO i = 1, m
527 work( i, k-l+j ) = b( i, j )
528 END DO
529 END DO
530 CALL dtrmm( 'R', 'L', 'N', 'N', m, l, one, v( 1, kp ), ldv,
531 $ work( 1, kp ), ldwork )
532 CALL dgemm( 'N', 'N', m, l, n-l, one, b( 1, np ), ldb,
533 $ v( np, kp ), ldv, one, work( 1, kp ), ldwork )
534 CALL dgemm( 'N', 'N', m, k-l, n, one, b, ldb,
535 $ v, ldv, zero, work, ldwork )
536*
537 DO j = 1, k
538 DO i = 1, m
539 work( i, j ) = work( i, j ) + a( i, j )
540 END DO
541 END DO
542*
543 CALL dtrmm( 'R', 'L', trans, 'N', m, k, one, t, ldt,
544 $ work, ldwork )
545*
546 DO j = 1, k
547 DO i = 1, m
548 a( i, j ) = a( i, j ) - work( i, j )
549 END DO
550 END DO
551*
552 CALL dgemm( 'N', 'T', m, n-l, k, -one, work, ldwork,
553 $ v( np, 1 ), ldv, one, b( 1, np ), ldb )
554 CALL dgemm( 'N', 'T', m, l, k-l, -one, work, ldwork,
555 $ v, ldv, one, b, ldb )
556 CALL dtrmm( 'R', 'L', 'T', 'N', m, l, one, v( 1, kp ), ldv,
557 $ work( 1, kp ), ldwork )
558 DO j = 1, l
559 DO i = 1, m
560 b( i, j ) = b( i, j ) - work( i, k-l+j )
561 END DO
562 END DO
563*
564* ---------------------------------------------------------------------------
565*
566 ELSE IF( row .AND. forward .AND. left ) THEN
567*
568* ---------------------------------------------------------------------------
569*
570* Let W = [ I V ] ( I is K-by-K, V is K-by-M )
571*
572* Form H C or H**T C where C = [ A ] (K-by-N)
573* [ B ] (M-by-N)
574*
575* H = I - W**T T W or H**T = I - W**T T**T W
576*
577* A = A - T (A + V B) or A = A - T**T (A + V B)
578* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B)
579*
580* ---------------------------------------------------------------------------
581*
582 mp = min( m-l+1, m )
583 kp = min( l+1, k )
584*
585 DO j = 1, n
586 DO i = 1, l
587 work( i, j ) = b( m-l+i, j )
588 END DO
589 END DO
590 CALL dtrmm( 'L', 'L', 'N', 'N', l, n, one, v( 1, mp ), ldv,
591 $ work, ldb )
592 CALL dgemm( 'N', 'N', l, n, m-l, one, v, ldv,b, ldb,
593 $ one, work, ldwork )
594 CALL dgemm( 'N', 'N', k-l, n, m, one, v( kp, 1 ), ldv,
595 $ b, ldb, zero, work( kp, 1 ), ldwork )
596*
597 DO j = 1, n
598 DO i = 1, k
599 work( i, j ) = work( i, j ) + a( i, j )
600 END DO
601 END DO
602*
603 CALL dtrmm( 'L', 'U', trans, 'N', k, n, one, t, ldt,
604 $ work, ldwork )
605*
606 DO j = 1, n
607 DO i = 1, k
608 a( i, j ) = a( i, j ) - work( i, j )
609 END DO
610 END DO
611*
612 CALL dgemm( 'T', 'N', m-l, n, k, -one, v, ldv, work, ldwork,
613 $ one, b, ldb )
614 CALL dgemm( 'T', 'N', l, n, k-l, -one, v( kp, mp ), ldv,
615 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
616 CALL dtrmm( 'L', 'L', 'T', 'N', l, n, one, v( 1, mp ), ldv,
617 $ work, ldwork )
618 DO j = 1, n
619 DO i = 1, l
620 b( m-l+i, j ) = b( m-l+i, j ) - work( i, j )
621 END DO
622 END DO
623*
624* ---------------------------------------------------------------------------
625*
626 ELSE IF( row .AND. forward .AND. right ) THEN
627*
628* ---------------------------------------------------------------------------
629*
630* Let W = [ I V ] ( I is K-by-K, V is K-by-N )
631*
632* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N)
633*
634* H = I - W**T T W or H**T = I - W**T T**T W
635*
636* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T
637* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V
638*
639* ---------------------------------------------------------------------------
640*
641 np = min( n-l+1, n )
642 kp = min( l+1, k )
643*
644 DO j = 1, l
645 DO i = 1, m
646 work( i, j ) = b( i, n-l+j )
647 END DO
648 END DO
649 CALL dtrmm( 'R', 'L', 'T', 'N', m, l, one, v( 1, np ), ldv,
650 $ work, ldwork )
651 CALL dgemm( 'N', 'T', m, l, n-l, one, b, ldb, v, ldv,
652 $ one, work, ldwork )
653 CALL dgemm( 'N', 'T', m, k-l, n, one, b, ldb,
654 $ v( kp, 1 ), ldv, zero, work( 1, kp ), ldwork )
655*
656 DO j = 1, k
657 DO i = 1, m
658 work( i, j ) = work( i, j ) + a( i, j )
659 END DO
660 END DO
661*
662 CALL dtrmm( 'R', 'U', trans, 'N', m, k, one, t, ldt,
663 $ work, ldwork )
664*
665 DO j = 1, k
666 DO i = 1, m
667 a( i, j ) = a( i, j ) - work( i, j )
668 END DO
669 END DO
670*
671 CALL dgemm( 'N', 'N', m, n-l, k, -one, work, ldwork,
672 $ v, ldv, one, b, ldb )
673 CALL dgemm( 'N', 'N', m, l, k-l, -one, work( 1, kp ), ldwork,
674 $ v( kp, np ), ldv, one, b( 1, np ), ldb )
675 CALL dtrmm( 'R', 'L', 'N', 'N', m, l, one, v( 1, np ), ldv,
676 $ work, ldwork )
677 DO j = 1, l
678 DO i = 1, m
679 b( i, n-l+j ) = b( i, n-l+j ) - work( i, j )
680 END DO
681 END DO
682*
683* ---------------------------------------------------------------------------
684*
685 ELSE IF( row .AND. backward .AND. left ) THEN
686*
687* ---------------------------------------------------------------------------
688*
689* Let W = [ V I ] ( I is K-by-K, V is K-by-M )
690*
691* Form H C or H**T C where C = [ B ] (M-by-N)
692* [ A ] (K-by-N)
693*
694* H = I - W**T T W or H**T = I - W**T T**T W
695*
696* A = A - T (A + V B) or A = A - T**T (A + V B)
697* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B)
698*
699* ---------------------------------------------------------------------------
700*
701 mp = min( l+1, m )
702 kp = min( k-l+1, k )
703*
704 DO j = 1, n
705 DO i = 1, l
706 work( k-l+i, j ) = b( i, j )
707 END DO
708 END DO
709 CALL dtrmm( 'L', 'U', 'N', 'N', l, n, one, v( kp, 1 ), ldv,
710 $ work( kp, 1 ), ldwork )
711 CALL dgemm( 'N', 'N', l, n, m-l, one, v( kp, mp ), ldv,
712 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
713 CALL dgemm( 'N', 'N', k-l, n, m, one, v, ldv, b, ldb,
714 $ zero, work, ldwork )
715*
716 DO j = 1, n
717 DO i = 1, k
718 work( i, j ) = work( i, j ) + a( i, j )
719 END DO
720 END DO
721*
722 CALL dtrmm( 'L', 'L ', trans, 'N', k, n, one, t, ldt,
723 $ work, ldwork )
724*
725 DO j = 1, n
726 DO i = 1, k
727 a( i, j ) = a( i, j ) - work( i, j )
728 END DO
729 END DO
730*
731 CALL dgemm( 'T', 'N', m-l, n, k, -one, v( 1, mp ), ldv,
732 $ work, ldwork, one, b( mp, 1 ), ldb )
733 CALL dgemm( 'T', 'N', l, n, k-l, -one, v, ldv,
734 $ work, ldwork, one, b, ldb )
735 CALL dtrmm( 'L', 'U', 'T', 'N', l, n, one, v( kp, 1 ), ldv,
736 $ work( kp, 1 ), ldwork )
737 DO j = 1, n
738 DO i = 1, l
739 b( i, j ) = b( i, j ) - work( k-l+i, j )
740 END DO
741 END DO
742*
743* ---------------------------------------------------------------------------
744*
745 ELSE IF( row .AND. backward .AND. right ) THEN
746*
747* ---------------------------------------------------------------------------
748*
749* Let W = [ V I ] ( I is K-by-K, V is K-by-N )
750*
751* Form C H or C H**T where C = [ B A ] (A is M-by-K, B is M-by-N)
752*
753* H = I - W**T T W or H**T = I - W**T T**T W
754*
755* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T
756* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V
757*
758* ---------------------------------------------------------------------------
759*
760 np = min( l+1, n )
761 kp = min( k-l+1, k )
762*
763 DO j = 1, l
764 DO i = 1, m
765 work( i, k-l+j ) = b( i, j )
766 END DO
767 END DO
768 CALL dtrmm( 'R', 'U', 'T', 'N', m, l, one, v( kp, 1 ), ldv,
769 $ work( 1, kp ), ldwork )
770 CALL dgemm( 'N', 'T', m, l, n-l, one, b( 1, np ), ldb,
771 $ v( kp, np ), ldv, one, work( 1, kp ), ldwork )
772 CALL dgemm( 'N', 'T', m, k-l, n, one, b, ldb, v, ldv,
773 $ zero, work, ldwork )
774*
775 DO j = 1, k
776 DO i = 1, m
777 work( i, j ) = work( i, j ) + a( i, j )
778 END DO
779 END DO
780*
781 CALL dtrmm( 'R', 'L', trans, 'N', m, k, one, t, ldt,
782 $ work, ldwork )
783*
784 DO j = 1, k
785 DO i = 1, m
786 a( i, j ) = a( i, j ) - work( i, j )
787 END DO
788 END DO
789*
790 CALL dgemm( 'N', 'N', m, n-l, k, -one, work, ldwork,
791 $ v( 1, np ), ldv, one, b( 1, np ), ldb )
792 CALL dgemm( 'N', 'N', m, l, k-l , -one, work, ldwork,
793 $ v, ldv, one, b, ldb )
794 CALL dtrmm( 'R', 'U', 'N', 'N', m, l, one, v( kp, 1 ), ldv,
795 $ work( 1, kp ), ldwork )
796 DO j = 1, l
797 DO i = 1, m
798 b( i, j ) = b( i, j ) - work( i, k-l+j )
799 END DO
800 END DO
801*
802 END IF
803*
804 RETURN
805*
806* End of DTPRFB
807*

◆ slatrd()

subroutine slatrd ( character uplo,
integer n,
integer nb,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) e,
real, dimension( * ) tau,
real, dimension( ldw, * ) w,
integer ldw )

SLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an orthogonal similarity transformation.

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

Purpose:
!>
!> SLATRD reduces NB rows and columns of a real symmetric matrix A to
!> symmetric tridiagonal form by an orthogonal similarity
!> transformation Q**T * A * Q, and returns the matrices V and W which are
!> needed to apply the transformation to the unreduced part of A.
!>
!> If UPLO = 'U', SLATRD reduces the last NB rows and columns of a
!> matrix, of which the upper triangle is supplied;
!> if UPLO = 'L', SLATRD reduces the first NB rows and columns of a
!> matrix, of which the lower triangle is supplied.
!>
!> This is an auxiliary routine called by SSYTRD.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U': Upper triangular
!>          = 'L': Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.
!>
[in]NB
!>          NB is INTEGER
!>          The number of rows and columns to be reduced.
!>
[in,out]A
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          n-by-n upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading n-by-n lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit:
!>          if UPLO = 'U', the last NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements above the diagonal
!>            with the array TAU, represent the orthogonal matrix Q as a
!>            product of elementary reflectors;
!>          if UPLO = 'L', the first NB columns have been reduced to
!>            tridiagonal form, with the diagonal elements overwriting
!>            the diagonal elements of A; the elements below the diagonal
!>            with the array TAU, represent the  orthogonal matrix Q as a
!>            product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= (1,N).
!>
[out]E
!>          E is REAL array, dimension (N-1)
!>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
!>          elements of the last NB columns of the reduced matrix;
!>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
!>          the first NB columns of the reduced matrix.
!>
[out]TAU
!>          TAU is REAL array, dimension (N-1)
!>          The scalar factors of the elementary reflectors, stored in
!>          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
!>          See Further Details.
!>
[out]W
!>          W is REAL array, dimension (LDW,NB)
!>          The n-by-nb matrix W required to update the unreduced part
!>          of A.
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array W. LDW >= max(1,N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(n) H(n-1) . . . H(n-nb+1).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
!>  and tau in TAU(i-1).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
!>  and tau in TAU(i).
!>
!>  The elements of the vectors v together form the n-by-nb matrix V
!>  which is needed, with W, to apply the transformation to the unreduced
!>  part of the matrix, using a symmetric rank-2k update of the form:
!>  A := A - V*W**T - W*V**T.
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5 and nb = 2:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  a   a   a   v4  v5 )              (  d                  )
!>    (      a   a   v4  v5 )              (  1   d              )
!>    (          a   1   v5 )              (  v1  1   a          )
!>    (              d   1  )              (  v1  v2  a   a      )
!>    (                  d  )              (  v1  v2  a   a   a  )
!>
!>  where d denotes a diagonal element of the reduced matrix, a denotes
!>  an element of the original matrix that is unchanged, and vi denotes
!>  an element of the vector defining H(i).
!>

Definition at line 197 of file slatrd.f.

198*
199* -- LAPACK auxiliary routine --
200* -- LAPACK is a software package provided by Univ. of Tennessee, --
201* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
202*
203* .. Scalar Arguments ..
204 CHARACTER UPLO
205 INTEGER LDA, LDW, N, NB
206* ..
207* .. Array Arguments ..
208 REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
209* ..
210*
211* =====================================================================
212*
213* .. Parameters ..
214 REAL ZERO, ONE, HALF
215 parameter( zero = 0.0e+0, one = 1.0e+0, half = 0.5e+0 )
216* ..
217* .. Local Scalars ..
218 INTEGER I, IW
219 REAL ALPHA
220* ..
221* .. External Subroutines ..
222 EXTERNAL saxpy, sgemv, slarfg, sscal, ssymv
223* ..
224* .. External Functions ..
225 LOGICAL LSAME
226 REAL SDOT
227 EXTERNAL lsame, sdot
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC min
231* ..
232* .. Executable Statements ..
233*
234* Quick return if possible
235*
236 IF( n.LE.0 )
237 $ RETURN
238*
239 IF( lsame( uplo, 'U' ) ) THEN
240*
241* Reduce last NB columns of upper triangle
242*
243 DO 10 i = n, n - nb + 1, -1
244 iw = i - n + nb
245 IF( i.LT.n ) THEN
246*
247* Update A(1:i,i)
248*
249 CALL sgemv( 'No transpose', i, n-i, -one, a( 1, i+1 ),
250 $ lda, w( i, iw+1 ), ldw, one, a( 1, i ), 1 )
251 CALL sgemv( 'No transpose', i, n-i, -one, w( 1, iw+1 ),
252 $ ldw, a( i, i+1 ), lda, one, a( 1, i ), 1 )
253 END IF
254 IF( i.GT.1 ) THEN
255*
256* Generate elementary reflector H(i) to annihilate
257* A(1:i-2,i)
258*
259 CALL slarfg( i-1, a( i-1, i ), a( 1, i ), 1, tau( i-1 ) )
260 e( i-1 ) = a( i-1, i )
261 a( i-1, i ) = one
262*
263* Compute W(1:i-1,i)
264*
265 CALL ssymv( 'Upper', i-1, one, a, lda, a( 1, i ), 1,
266 $ zero, w( 1, iw ), 1 )
267 IF( i.LT.n ) THEN
268 CALL sgemv( 'Transpose', i-1, n-i, one, w( 1, iw+1 ),
269 $ ldw, a( 1, i ), 1, zero, w( i+1, iw ), 1 )
270 CALL sgemv( 'No transpose', i-1, n-i, -one,
271 $ a( 1, i+1 ), lda, w( i+1, iw ), 1, one,
272 $ w( 1, iw ), 1 )
273 CALL sgemv( 'Transpose', i-1, n-i, one, a( 1, i+1 ),
274 $ lda, a( 1, i ), 1, zero, w( i+1, iw ), 1 )
275 CALL sgemv( 'No transpose', i-1, n-i, -one,
276 $ w( 1, iw+1 ), ldw, w( i+1, iw ), 1, one,
277 $ w( 1, iw ), 1 )
278 END IF
279 CALL sscal( i-1, tau( i-1 ), w( 1, iw ), 1 )
280 alpha = -half*tau( i-1 )*sdot( i-1, w( 1, iw ), 1,
281 $ a( 1, i ), 1 )
282 CALL saxpy( i-1, alpha, a( 1, i ), 1, w( 1, iw ), 1 )
283 END IF
284*
285 10 CONTINUE
286 ELSE
287*
288* Reduce first NB columns of lower triangle
289*
290 DO 20 i = 1, nb
291*
292* Update A(i:n,i)
293*
294 CALL sgemv( 'No transpose', n-i+1, i-1, -one, a( i, 1 ),
295 $ lda, w( i, 1 ), ldw, one, a( i, i ), 1 )
296 CALL sgemv( 'No transpose', n-i+1, i-1, -one, w( i, 1 ),
297 $ ldw, a( i, 1 ), lda, one, a( i, i ), 1 )
298 IF( i.LT.n ) THEN
299*
300* Generate elementary reflector H(i) to annihilate
301* A(i+2:n,i)
302*
303 CALL slarfg( n-i, a( i+1, i ), a( min( i+2, n ), i ), 1,
304 $ tau( i ) )
305 e( i ) = a( i+1, i )
306 a( i+1, i ) = one
307*
308* Compute W(i+1:n,i)
309*
310 CALL ssymv( 'Lower', n-i, one, a( i+1, i+1 ), lda,
311 $ a( i+1, i ), 1, zero, w( i+1, i ), 1 )
312 CALL sgemv( 'Transpose', n-i, i-1, one, w( i+1, 1 ), ldw,
313 $ a( i+1, i ), 1, zero, w( 1, i ), 1 )
314 CALL sgemv( 'No transpose', n-i, i-1, -one, a( i+1, 1 ),
315 $ lda, w( 1, i ), 1, one, w( i+1, i ), 1 )
316 CALL sgemv( 'Transpose', n-i, i-1, one, a( i+1, 1 ), lda,
317 $ a( i+1, i ), 1, zero, w( 1, i ), 1 )
318 CALL sgemv( 'No transpose', n-i, i-1, -one, w( i+1, 1 ),
319 $ ldw, w( 1, i ), 1, one, w( i+1, i ), 1 )
320 CALL sscal( n-i, tau( i ), w( i+1, i ), 1 )
321 alpha = -half*tau( i )*sdot( n-i, w( i+1, i ), 1,
322 $ a( i+1, i ), 1 )
323 CALL saxpy( n-i, alpha, a( i+1, i ), 1, w( i+1, i ), 1 )
324 END IF
325*
326 20 CONTINUE
327 END IF
328*
329 RETURN
330*
331* End of SLATRD
332*
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
ssymv
subroutine ssymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
SSYMV
Definition ssymv.f:152