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

Functions

subroutine clabrd (m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
 CLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
subroutine clacgv (n, x, incx)
 CLACGV conjugates a complex vector.
subroutine clacn2 (n, v, x, est, kase, isave)
 CLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine clacon (n, v, x, est, kase)
 CLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine clacp2 (uplo, m, n, a, lda, b, ldb)
 CLACP2 copies all or part of a real two-dimensional array to a complex array.
subroutine clacpy (uplo, m, n, a, lda, b, ldb)
 CLACPY copies all or part of one two-dimensional array to another.
subroutine clacrm (m, n, a, lda, b, ldb, c, ldc, rwork)
 CLACRM multiplies a complex matrix by a square real matrix.
subroutine clacrt (n, cx, incx, cy, incy, c, s)
 CLACRT performs a linear transformation of a pair of complex vectors.
complex function cladiv (x, y)
 CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
subroutine claein (rightv, noinit, n, h, ldh, w, v, b, ldb, rwork, eps3, smlnum, info)
 CLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration.
subroutine claev2 (a, b, c, rt1, rt2, cs1, sn1)
 CLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
subroutine clags2 (upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
 CLAGS2
subroutine clagtm (trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
 CLAGTM 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 clahqr (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, info)
 CLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
subroutine clahr2 (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 CLAHR2 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 claic1 (job, j, x, sest, w, gamma, sestpr, s, c)
 CLAIC1 applies one step of incremental condition estimation.
real function clangt (norm, n, dl, d, du)
 CLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix.
real function clanhb (norm, uplo, n, k, ab, ldab, work)
 CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
real function clanhp (norm, uplo, n, ap, work)
 CLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix supplied in packed form.
real function clanhs (norm, n, a, lda, work)
 CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.
real function clanht (norm, n, d, e)
 CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian tridiagonal matrix.
real function clansb (norm, uplo, n, k, ab, ldab, work)
 CLANSB 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.
real function clansp (norm, uplo, n, ap, work)
 CLANSP 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.
real function clantb (norm, uplo, diag, n, k, ab, ldab, work)
 CLANTB 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.
real function clantp (norm, uplo, diag, n, ap, work)
 CLANTP 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.
real function clantr (norm, uplo, diag, m, n, a, lda, work)
 CLANTR 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 clapll (n, x, incx, y, incy, ssmin)
 CLAPLL measures the linear dependence of two vectors.
subroutine clapmr (forwrd, m, n, x, ldx, k)
 CLAPMR rearranges rows of a matrix as specified by a permutation vector.
subroutine clapmt (forwrd, m, n, x, ldx, k)
 CLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine claqhb (uplo, n, kd, ab, ldab, s, scond, amax, equed)
 CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
subroutine claqhp (uplo, n, ap, s, scond, amax, equed)
 CLAQHP scales a Hermitian matrix stored in packed form.
subroutine claqp2 (m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
 CLAQP2 computes a QR factorization with column pivoting of the matrix block.
subroutine claqps (m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
 CLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.
subroutine claqr0 (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, work, lwork, info)
 CLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine claqr1 (n, h, ldh, s1, s2, v)
 CLAQR1 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 claqr2 (wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sh, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
 CLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
subroutine claqr3 (wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz, ihiz, z, ldz, ns, nd, sh, v, ldv, nh, t, ldt, nv, wv, ldwv, work, lwork)
 CLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation).
subroutine claqr4 (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, work, lwork, info)
 CLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine claqr5 (wantt, wantz, kacc22, n, ktop, kbot, nshfts, s, h, ldh, iloz, ihiz, z, ldz, v, ldv, u, ldu, nv, wv, ldwv, nh, wh, ldwh)
 CLAQR5 performs a single small-bulge multi-shift QR sweep.
subroutine claqsb (uplo, n, kd, ab, ldab, s, scond, amax, equed)
 CLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ.
subroutine claqsp (uplo, n, ap, s, scond, amax, equed)
 CLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ.
subroutine clar1v (n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
 CLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI.
subroutine clar2v (n, x, y, z, incx, c, s, incc)
 CLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.
subroutine clarcm (m, n, a, lda, b, ldb, c, ldc, rwork)
 CLARCM copies all or part of a real two-dimensional array to a complex array.
subroutine clarf (side, m, n, v, incv, tau, c, ldc, work)
 CLARF applies an elementary reflector to a general rectangular matrix.
subroutine clarfb (side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
 CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
subroutine clarfb_gett (ident, m, n, k, t, ldt, a, lda, b, ldb, work, ldwork)
 CLARFB_GETT
subroutine clarfg (n, alpha, x, incx, tau)
 CLARFG generates an elementary reflector (Householder matrix).
subroutine clarfgp (n, alpha, x, incx, tau)
 CLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
subroutine clarft (direct, storev, n, k, v, ldv, tau, t, ldt)
 CLARFT forms the triangular factor T of a block reflector H = I - vtvH
subroutine clarfx (side, m, n, v, tau, c, ldc, work)
 CLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.
subroutine clarfy (uplo, n, v, incv, tau, c, ldc, work)
 CLARFY
subroutine clargv (n, x, incx, y, incy, c, incc)
 CLARGV generates a vector of plane rotations with real cosines and complex sines.
subroutine clarnv (idist, iseed, n, x)
 CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine clarrv (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)
 CLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT.
subroutine clartv (n, x, incx, y, incy, c, s, incc)
 CLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a pair of vectors.
subroutine clascl (type, kl, ku, cfrom, cto, m, n, a, lda, info)
 CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine claset (uplo, m, n, alpha, beta, a, lda)
 CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine clasr (side, pivot, direct, m, n, c, s, a, lda)
 CLASR applies a sequence of plane rotations to a general rectangular matrix.
subroutine claswp (n, a, lda, k1, k2, ipiv, incx)
 CLASWP performs a series of row interchanges on a general rectangular matrix.
subroutine clatbs (uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
 CLATBS solves a triangular banded system of equations.
subroutine clatdf (ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv)
 CLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
subroutine clatps (uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
 CLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine clatrd (uplo, n, nb, a, lda, e, tau, w, ldw)
 CLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
subroutine clatrs (uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
 CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
subroutine clauu2 (uplo, n, a, lda, info)
 CLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).
subroutine clauum (uplo, n, a, lda, info)
 CLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
subroutine crot (n, cx, incx, cy, incy, c, s)
 CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
subroutine cspmv (uplo, n, alpha, ap, x, incx, beta, y, incy)
 CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
subroutine cspr (uplo, n, alpha, x, incx, ap)
 CSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.
subroutine csrscl (n, sa, sx, incx)
 CSRSCL multiplies a vector by the reciprocal of a real scalar.
subroutine ctprfb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
 CTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks.
subroutine clahrd (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 CLAHRD 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.
integer function icmax1 (n, cx, incx)
 ICMAX1 finds the index of the first vector element of maximum absolute value.
integer function ilaclc (m, n, a, lda)
 ILACLC scans a matrix for its last non-zero column.
integer function ilaclr (m, n, a, lda)
 ILACLR scans a matrix for its last non-zero row.
integer function izmax1 (n, zx, incx)
 IZMAX1 finds the index of the first vector element of maximum absolute value.
real function scsum1 (n, cx, incx)
 SCSUM1 forms the 1-norm of the complex vector using the true absolute value.

Detailed Description

This is the group of complex other auxiliary routines

Function Documentation

◆ clabrd()

subroutine clabrd ( integer m,
integer n,
integer nb,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) d,
real, dimension( * ) e,
complex, dimension( * ) tauq,
complex, dimension( * ) taup,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldy, * ) y,
integer ldy )

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

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

Purpose:
!>
!> CLABRD reduces the first NB rows and columns of a complex general
!> m by n matrix A to upper or lower real bidiagonal form by a unitary
!> transformation Q**H * 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 CGEBRD
!>
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 COMPLEX 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 unitary
!>            matrix Q as a product of elementary reflectors; and
!>            elements above the diagonal in the first NB rows, with the
!>            array TAUP, represent the unitary 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 unitary
!>            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 unitary 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 REAL 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 REAL array, dimension (NB)
!>          The off-diagonal elements of the first NB rows and columns of
!>          the reduced matrix.
!>
[out]TAUQ
!>          TAUQ is COMPLEX array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is COMPLEX array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix P. See Further Details.
!>
[out]X
!>          X is COMPLEX 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 COMPLEX 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**H  and G(i) = I - taup * u * u**H
!>
!>  where tauq and taup are complex scalars, and v and u are complex
!>  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**H 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**H - X*U**H.
!>
!>  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 210 of file clabrd.f.

212*
213* -- LAPACK auxiliary routine --
214* -- LAPACK is a software package provided by Univ. of Tennessee, --
215* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216*
217* .. Scalar Arguments ..
218 INTEGER LDA, LDX, LDY, M, N, NB
219* ..
220* .. Array Arguments ..
221 REAL D( * ), E( * )
222 COMPLEX A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
223 $ Y( LDY, * )
224* ..
225*
226* =====================================================================
227*
228* .. Parameters ..
229 COMPLEX ZERO, ONE
230 parameter( zero = ( 0.0e+0, 0.0e+0 ),
231 $ one = ( 1.0e+0, 0.0e+0 ) )
232* ..
233* .. Local Scalars ..
234 INTEGER I
235 COMPLEX ALPHA
236* ..
237* .. External Subroutines ..
238 EXTERNAL cgemv, clacgv, clarfg, cscal
239* ..
240* .. Intrinsic Functions ..
241 INTRINSIC min
242* ..
243* .. Executable Statements ..
244*
245* Quick return if possible
246*
247 IF( m.LE.0 .OR. n.LE.0 )
248 $ RETURN
249*
250 IF( m.GE.n ) THEN
251*
252* Reduce to upper bidiagonal form
253*
254 DO 10 i = 1, nb
255*
256* Update A(i:m,i)
257*
258 CALL clacgv( i-1, y( i, 1 ), ldy )
259 CALL cgemv( 'No transpose', m-i+1, i-1, -one, a( i, 1 ),
260 $ lda, y( i, 1 ), ldy, one, a( i, i ), 1 )
261 CALL clacgv( i-1, y( i, 1 ), ldy )
262 CALL cgemv( 'No transpose', m-i+1, i-1, -one, x( i, 1 ),
263 $ ldx, a( 1, i ), 1, one, a( i, i ), 1 )
264*
265* Generate reflection Q(i) to annihilate A(i+1:m,i)
266*
267 alpha = a( i, i )
268 CALL clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,
269 $ tauq( i ) )
270 d( i ) = real( alpha )
271 IF( i.LT.n ) THEN
272 a( i, i ) = one
273*
274* Compute Y(i+1:n,i)
275*
276 CALL cgemv( 'Conjugate transpose', m-i+1, n-i, one,
277 $ a( i, i+1 ), lda, a( i, i ), 1, zero,
278 $ y( i+1, i ), 1 )
279 CALL cgemv( 'Conjugate transpose', m-i+1, i-1, one,
280 $ a( i, 1 ), lda, a( i, i ), 1, zero,
281 $ y( 1, i ), 1 )
282 CALL cgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
283 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
284 CALL cgemv( 'Conjugate transpose', m-i+1, i-1, one,
285 $ x( i, 1 ), ldx, a( i, i ), 1, zero,
286 $ y( 1, i ), 1 )
287 CALL cgemv( 'Conjugate transpose', i-1, n-i, -one,
288 $ a( 1, i+1 ), lda, y( 1, i ), 1, one,
289 $ y( i+1, i ), 1 )
290 CALL cscal( n-i, tauq( i ), y( i+1, i ), 1 )
291*
292* Update A(i,i+1:n)
293*
294 CALL clacgv( n-i, a( i, i+1 ), lda )
295 CALL clacgv( i, a( i, 1 ), lda )
296 CALL cgemv( 'No transpose', n-i, i, -one, y( i+1, 1 ),
297 $ ldy, a( i, 1 ), lda, one, a( i, i+1 ), lda )
298 CALL clacgv( i, a( i, 1 ), lda )
299 CALL clacgv( i-1, x( i, 1 ), ldx )
300 CALL cgemv( 'Conjugate transpose', i-1, n-i, -one,
301 $ a( 1, i+1 ), lda, x( i, 1 ), ldx, one,
302 $ a( i, i+1 ), lda )
303 CALL clacgv( i-1, x( i, 1 ), ldx )
304*
305* Generate reflection P(i) to annihilate A(i,i+2:n)
306*
307 alpha = a( i, i+1 )
308 CALL clarfg( n-i, alpha, a( i, min( i+2, n ) ),
309 $ lda, taup( i ) )
310 e( i ) = real( alpha )
311 a( i, i+1 ) = one
312*
313* Compute X(i+1:m,i)
314*
315 CALL cgemv( 'No transpose', m-i, n-i, one, a( i+1, i+1 ),
316 $ lda, a( i, i+1 ), lda, zero, x( i+1, i ), 1 )
317 CALL cgemv( 'Conjugate transpose', n-i, i, one,
318 $ y( i+1, 1 ), ldy, a( i, i+1 ), lda, zero,
319 $ x( 1, i ), 1 )
320 CALL cgemv( 'No transpose', m-i, i, -one, a( i+1, 1 ),
321 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
322 CALL cgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
323 $ lda, a( i, i+1 ), lda, zero, x( 1, i ), 1 )
324 CALL cgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
325 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
326 CALL cscal( m-i, taup( i ), x( i+1, i ), 1 )
327 CALL clacgv( n-i, a( i, i+1 ), lda )
328 END IF
329 10 CONTINUE
330 ELSE
331*
332* Reduce to lower bidiagonal form
333*
334 DO 20 i = 1, nb
335*
336* Update A(i,i:n)
337*
338 CALL clacgv( n-i+1, a( i, i ), lda )
339 CALL clacgv( i-1, a( i, 1 ), lda )
340 CALL cgemv( 'No transpose', n-i+1, i-1, -one, y( i, 1 ),
341 $ ldy, a( i, 1 ), lda, one, a( i, i ), lda )
342 CALL clacgv( i-1, a( i, 1 ), lda )
343 CALL clacgv( i-1, x( i, 1 ), ldx )
344 CALL cgemv( 'Conjugate transpose', i-1, n-i+1, -one,
345 $ a( 1, i ), lda, x( i, 1 ), ldx, one, a( i, i ),
346 $ lda )
347 CALL clacgv( i-1, x( i, 1 ), ldx )
348*
349* Generate reflection P(i) to annihilate A(i,i+1:n)
350*
351 alpha = a( i, i )
352 CALL clarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,
353 $ taup( i ) )
354 d( i ) = real( alpha )
355 IF( i.LT.m ) THEN
356 a( i, i ) = one
357*
358* Compute X(i+1:m,i)
359*
360 CALL cgemv( 'No transpose', m-i, n-i+1, one, a( i+1, i ),
361 $ lda, a( i, i ), lda, zero, x( i+1, i ), 1 )
362 CALL cgemv( 'Conjugate transpose', n-i+1, i-1, one,
363 $ y( i, 1 ), ldy, a( i, i ), lda, zero,
364 $ x( 1, i ), 1 )
365 CALL cgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
366 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
367 CALL cgemv( 'No transpose', i-1, n-i+1, one, a( 1, i ),
368 $ lda, a( i, i ), lda, zero, x( 1, i ), 1 )
369 CALL cgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
370 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
371 CALL cscal( m-i, taup( i ), x( i+1, i ), 1 )
372 CALL clacgv( n-i+1, a( i, i ), lda )
373*
374* Update A(i+1:m,i)
375*
376 CALL clacgv( i-1, y( i, 1 ), ldy )
377 CALL cgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
378 $ lda, y( i, 1 ), ldy, one, a( i+1, i ), 1 )
379 CALL clacgv( i-1, y( i, 1 ), ldy )
380 CALL cgemv( 'No transpose', m-i, i, -one, x( i+1, 1 ),
381 $ ldx, a( 1, i ), 1, one, a( i+1, i ), 1 )
382*
383* Generate reflection Q(i) to annihilate A(i+2:m,i)
384*
385 alpha = a( i+1, i )
386 CALL clarfg( m-i, alpha, a( min( i+2, m ), i ), 1,
387 $ tauq( i ) )
388 e( i ) = real( alpha )
389 a( i+1, i ) = one
390*
391* Compute Y(i+1:n,i)
392*
393 CALL cgemv( 'Conjugate transpose', m-i, n-i, one,
394 $ a( i+1, i+1 ), lda, a( i+1, i ), 1, zero,
395 $ y( i+1, i ), 1 )
396 CALL cgemv( 'Conjugate transpose', m-i, i-1, one,
397 $ a( i+1, 1 ), lda, a( i+1, i ), 1, zero,
398 $ y( 1, i ), 1 )
399 CALL cgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
400 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
401 CALL cgemv( 'Conjugate transpose', m-i, i, one,
402 $ x( i+1, 1 ), ldx, a( i+1, i ), 1, zero,
403 $ y( 1, i ), 1 )
404 CALL cgemv( 'Conjugate transpose', i, n-i, -one,
405 $ a( 1, i+1 ), lda, y( 1, i ), 1, one,
406 $ y( i+1, i ), 1 )
407 CALL cscal( n-i, tauq( i ), y( i+1, i ), 1 )
408 ELSE
409 CALL clacgv( n-i+1, a( i, i ), lda )
410 END IF
411 20 CONTINUE
412 END IF
413 RETURN
414*
415* End of CLABRD
416*
alpha
#define alpha
Definition eval.h:35
clarfg
subroutine clarfg(n, alpha, x, incx, tau)
CLARFG generates an elementary reflector (Householder matrix).
Definition clarfg.f:106
clacgv
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
Definition clacgv.f:74
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
min
#define min(a, b)
Definition macros.h:20

◆ clacgv()

subroutine clacgv ( integer n,
complex, dimension( * ) x,
integer incx )

CLACGV conjugates a complex vector.

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

Purpose:
!>
!> CLACGV conjugates a complex vector of length N.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The length of the vector X.  N >= 0.
!>
[in,out]X
!>          X is COMPLEX array, dimension
!>                         (1+(N-1)*abs(INCX))
!>          On entry, the vector of length N to be conjugated.
!>          On exit, X is overwritten with conjg(X).
!>
[in]INCX
!>          INCX is INTEGER
!>          The spacing between successive elements of X.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 73 of file clacgv.f.

74*
75* -- LAPACK auxiliary routine --
76* -- LAPACK is a software package provided by Univ. of Tennessee, --
77* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
78*
79* .. Scalar Arguments ..
80 INTEGER INCX, N
81* ..
82* .. Array Arguments ..
83 COMPLEX X( * )
84* ..
85*
86* =====================================================================
87*
88* .. Local Scalars ..
89 INTEGER I, IOFF
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC conjg
93* ..
94* .. Executable Statements ..
95*
96 IF( incx.EQ.1 ) THEN
97 DO 10 i = 1, n
98 x( i ) = conjg( x( i ) )
99 10 CONTINUE
100 ELSE
101 ioff = 1
102 IF( incx.LT.0 )
103 $ ioff = 1 - ( n-1 )*incx
104 DO 20 i = 1, n
105 x( ioff ) = conjg( x( ioff ) )
106 ioff = ioff + incx
107 20 CONTINUE
108 END IF
109 RETURN
110*
111* End of CLACGV
112*

◆ clacn2()

subroutine clacn2 ( integer n,
complex, dimension( * ) v,
complex, dimension( * ) x,
real est,
integer kase,
integer, dimension( 3 ) isave )

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

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

Purpose:
!>
!> CLACN2 estimates the 1-norm of a square, complex 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 COMPLEX 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 COMPLEX array, dimension (N)
!>         On an intermediate return, X should be overwritten by
!>               A * X,   if KASE=1,
!>               A**H * X,  if KASE=2,
!>         where A**H is the conjugate transpose of A, and CLACN2 must be
!>         re-called with all the other parameters unchanged.
!>
[in,out]EST
!>          EST is REAL
!>         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
!>         unchanged from the previous call to CLACN2.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to CLACN2, 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**H * X.
!>         On the final return from CLACN2, KASE will again be 0.
!>
[in,out]ISAVE
!>          ISAVE is INTEGER array, dimension (3)
!>         ISAVE is used to save variables between calls to SLACN2
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  Originally named CONEST, dated March 16, 1988.
!>
!>  Last modified:  April, 1999
!>
!>  This is a thread safe version of CLACON, which uses the array ISAVE
!>  in place of a SAVE statement, as follows:
!>
!>     CLACON     CLACN2
!>      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 132 of file clacn2.f.

133*
134* -- LAPACK auxiliary routine --
135* -- LAPACK is a software package provided by Univ. of Tennessee, --
136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137*
138* .. Scalar Arguments ..
139 INTEGER KASE, N
140 REAL EST
141* ..
142* .. Array Arguments ..
143 INTEGER ISAVE( 3 )
144 COMPLEX V( * ), X( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 INTEGER ITMAX
151 parameter( itmax = 5 )
152 REAL ONE, TWO
153 parameter( one = 1.0e0, two = 2.0e0 )
154 COMPLEX CZERO, CONE
155 parameter( czero = ( 0.0e0, 0.0e0 ),
156 $ cone = ( 1.0e0, 0.0e0 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER I, JLAST
160 REAL ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
161* ..
162* .. External Functions ..
163 INTEGER ICMAX1
164 REAL SCSUM1, SLAMCH
165 EXTERNAL icmax1, scsum1, slamch
166* ..
167* .. External Subroutines ..
168 EXTERNAL ccopy
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, aimag, cmplx, real
172* ..
173* .. Executable Statements ..
174*
175 safmin = slamch( 'Safe minimum' )
176 IF( kase.EQ.0 ) THEN
177 DO 10 i = 1, n
178 x( i ) = cmplx( one / real( n ) )
179 10 CONTINUE
180 kase = 1
181 isave( 1 ) = 1
182 RETURN
183 END IF
184*
185 GO TO ( 20, 40, 70, 90, 120 )isave( 1 )
186*
187* ................ ENTRY (ISAVE( 1 ) = 1)
188* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
189*
190 20 CONTINUE
191 IF( n.EQ.1 ) THEN
192 v( 1 ) = x( 1 )
193 est = abs( v( 1 ) )
194* ... QUIT
195 GO TO 130
196 END IF
197 est = scsum1( n, x, 1 )
198*
199 DO 30 i = 1, n
200 absxi = abs( x( i ) )
201 IF( absxi.GT.safmin ) THEN
202 x( i ) = cmplx( real( x( i ) ) / absxi,
203 $ aimag( x( i ) ) / absxi )
204 ELSE
205 x( i ) = cone
206 END IF
207 30 CONTINUE
208 kase = 2
209 isave( 1 ) = 2
210 RETURN
211*
212* ................ ENTRY (ISAVE( 1 ) = 2)
213* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
214*
215 40 CONTINUE
216 isave( 2 ) = icmax1( n, x, 1 )
217 isave( 3 ) = 2
218*
219* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
220*
221 50 CONTINUE
222 DO 60 i = 1, n
223 x( i ) = czero
224 60 CONTINUE
225 x( isave( 2 ) ) = cone
226 kase = 1
227 isave( 1 ) = 3
228 RETURN
229*
230* ................ ENTRY (ISAVE( 1 ) = 3)
231* X HAS BEEN OVERWRITTEN BY A*X.
232*
233 70 CONTINUE
234 CALL ccopy( n, x, 1, v, 1 )
235 estold = est
236 est = scsum1( n, v, 1 )
237*
238* TEST FOR CYCLING.
239 IF( est.LE.estold )
240 $ GO TO 100
241*
242 DO 80 i = 1, n
243 absxi = abs( x( i ) )
244 IF( absxi.GT.safmin ) THEN
245 x( i ) = cmplx( real( x( i ) ) / absxi,
246 $ aimag( x( i ) ) / absxi )
247 ELSE
248 x( i ) = cone
249 END IF
250 80 CONTINUE
251 kase = 2
252 isave( 1 ) = 4
253 RETURN
254*
255* ................ ENTRY (ISAVE( 1 ) = 4)
256* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
257*
258 90 CONTINUE
259 jlast = isave( 2 )
260 isave( 2 ) = icmax1( n, x, 1 )
261 IF( ( abs( x( jlast ) ).NE.abs( x( isave( 2 ) ) ) ) .AND.
262 $ ( isave( 3 ).LT.itmax ) ) THEN
263 isave( 3 ) = isave( 3 ) + 1
264 GO TO 50
265 END IF
266*
267* ITERATION COMPLETE. FINAL STAGE.
268*
269 100 CONTINUE
270 altsgn = one
271 DO 110 i = 1, n
272 x( i ) = cmplx( altsgn*( one + real( i-1 ) / real( n-1 ) ) )
273 altsgn = -altsgn
274 110 CONTINUE
275 kase = 1
276 isave( 1 ) = 5
277 RETURN
278*
279* ................ ENTRY (ISAVE( 1 ) = 5)
280* X HAS BEEN OVERWRITTEN BY A*X.
281*
282 120 CONTINUE
283 temp = two*( scsum1( n, x, 1 ) / real( 3*n ) )
284 IF( temp.GT.est ) THEN
285 CALL ccopy( n, x, 1, v, 1 )
286 est = temp
287 END IF
288*
289 130 CONTINUE
290 kase = 0
291 RETURN
292*
293* End of CLACN2
294*
cmplx
float cmplx[2]
Definition pblas.h:136
scsum1
real function scsum1(n, cx, incx)
SCSUM1 forms the 1-norm of the complex vector using the true absolute value.
Definition scsum1.f:81
icmax1
integer function icmax1(n, cx, incx)
ICMAX1 finds the index of the first vector element of maximum absolute value.
Definition icmax1.f:81
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ clacon()

subroutine clacon ( integer n,
complex, dimension( n ) v,
complex, dimension( n ) x,
real est,
integer kase )

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

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

Purpose:
!>
!> CLACON estimates the 1-norm of a square, complex 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 COMPLEX 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 COMPLEX array, dimension (N)
!>         On an intermediate return, X should be overwritten by
!>               A * X,   if KASE=1,
!>               A**H * X,  if KASE=2,
!>         where A**H is the conjugate transpose of A, and CLACON must be
!>         re-called with all the other parameters unchanged.
!>
[in,out]EST
!>          EST is REAL
!>         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
!>         unchanged from the previous call to CLACON.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to CLACON, 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**H * X.
!>         On the final return from CLACON, KASE will again be 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
Originally named CONEST, dated March 16, 1988.
Last modified: April, 1999
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 113 of file clacon.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 INTEGER KASE, N
121 REAL EST
122* ..
123* .. Array Arguments ..
124 COMPLEX V( N ), X( N )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 INTEGER ITMAX
131 parameter( itmax = 5 )
132 REAL ONE, TWO
133 parameter( one = 1.0e0, two = 2.0e0 )
134 COMPLEX CZERO, CONE
135 parameter( czero = ( 0.0e0, 0.0e0 ),
136 $ cone = ( 1.0e0, 0.0e0 ) )
137* ..
138* .. Local Scalars ..
139 INTEGER I, ITER, J, JLAST, JUMP
140 REAL ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
141* ..
142* .. External Functions ..
143 INTEGER ICMAX1
144 REAL SCSUM1, SLAMCH
145 EXTERNAL icmax1, scsum1, slamch
146* ..
147* .. External Subroutines ..
148 EXTERNAL ccopy
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC abs, aimag, cmplx, real
152* ..
153* .. Save statement ..
154 SAVE
155* ..
156* .. Executable Statements ..
157*
158 safmin = slamch( 'Safe minimum' )
159 IF( kase.EQ.0 ) THEN
160 DO 10 i = 1, n
161 x( i ) = cmplx( one / real( n ) )
162 10 CONTINUE
163 kase = 1
164 jump = 1
165 RETURN
166 END IF
167*
168 GO TO ( 20, 40, 70, 90, 120 )jump
169*
170* ................ ENTRY (JUMP = 1)
171* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
172*
173 20 CONTINUE
174 IF( n.EQ.1 ) THEN
175 v( 1 ) = x( 1 )
176 est = abs( v( 1 ) )
177* ... QUIT
178 GO TO 130
179 END IF
180 est = scsum1( n, x, 1 )
181*
182 DO 30 i = 1, n
183 absxi = abs( x( i ) )
184 IF( absxi.GT.safmin ) THEN
185 x( i ) = cmplx( real( x( i ) ) / absxi,
186 $ aimag( x( i ) ) / absxi )
187 ELSE
188 x( i ) = cone
189 END IF
190 30 CONTINUE
191 kase = 2
192 jump = 2
193 RETURN
194*
195* ................ ENTRY (JUMP = 2)
196* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
197*
198 40 CONTINUE
199 j = icmax1( n, x, 1 )
200 iter = 2
201*
202* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
203*
204 50 CONTINUE
205 DO 60 i = 1, n
206 x( i ) = czero
207 60 CONTINUE
208 x( j ) = cone
209 kase = 1
210 jump = 3
211 RETURN
212*
213* ................ ENTRY (JUMP = 3)
214* X HAS BEEN OVERWRITTEN BY A*X.
215*
216 70 CONTINUE
217 CALL ccopy( n, x, 1, v, 1 )
218 estold = est
219 est = scsum1( n, v, 1 )
220*
221* TEST FOR CYCLING.
222 IF( est.LE.estold )
223 $ GO TO 100
224*
225 DO 80 i = 1, n
226 absxi = abs( x( i ) )
227 IF( absxi.GT.safmin ) THEN
228 x( i ) = cmplx( real( x( i ) ) / absxi,
229 $ aimag( x( i ) ) / absxi )
230 ELSE
231 x( i ) = cone
232 END IF
233 80 CONTINUE
234 kase = 2
235 jump = 4
236 RETURN
237*
238* ................ ENTRY (JUMP = 4)
239* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
240*
241 90 CONTINUE
242 jlast = j
243 j = icmax1( n, x, 1 )
244 IF( ( abs( x( jlast ) ).NE.abs( x( j ) ) ) .AND.
245 $ ( iter.LT.itmax ) ) THEN
246 iter = iter + 1
247 GO TO 50
248 END IF
249*
250* ITERATION COMPLETE. FINAL STAGE.
251*
252 100 CONTINUE
253 altsgn = one
254 DO 110 i = 1, n
255 x( i ) = cmplx( altsgn*( one+real( i-1 ) / real( n-1 ) ) )
256 altsgn = -altsgn
257 110 CONTINUE
258 kase = 1
259 jump = 5
260 RETURN
261*
262* ................ ENTRY (JUMP = 5)
263* X HAS BEEN OVERWRITTEN BY A*X.
264*
265 120 CONTINUE
266 temp = two*( scsum1( n, x, 1 ) / real( 3*n ) )
267 IF( temp.GT.est ) THEN
268 CALL ccopy( n, x, 1, v, 1 )
269 est = temp
270 END IF
271*
272 130 CONTINUE
273 kase = 0
274 RETURN
275*
276* End of CLACON
277*

◆ clacp2()

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

CLACP2 copies all or part of a real two-dimensional array to a complex array.

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

Purpose:
!>
!> CLACP2 copies all or part of a real two-dimensional matrix A to a
!> complex matrix B.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies the part of the matrix A to be copied to B.
!>          = 'U':      Upper triangular part
!>          = 'L':      Lower triangular part
!>          Otherwise:  All of the matrix A
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is REAL array, dimension (LDA,N)
!>          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
!>          is accessed; if UPLO = 'L', only the lower trapezium is
!>          accessed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On exit, B = A in the locations specified by UPLO.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file clacp2.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 CHARACTER UPLO
111 INTEGER LDA, LDB, M, N
112* ..
113* .. Array Arguments ..
114 REAL A( LDA, * )
115 COMPLEX B( LDB, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, J
122* ..
123* .. External Functions ..
124 LOGICAL LSAME
125 EXTERNAL lsame
126* ..
127* .. Intrinsic Functions ..
128 INTRINSIC min
129* ..
130* .. Executable Statements ..
131*
132 IF( lsame( uplo, 'U' ) ) THEN
133 DO 20 j = 1, n
134 DO 10 i = 1, min( j, m )
135 b( i, j ) = a( i, j )
136 10 CONTINUE
137 20 CONTINUE
138*
139 ELSE IF( lsame( uplo, 'L' ) ) THEN
140 DO 40 j = 1, n
141 DO 30 i = j, m
142 b( i, j ) = a( i, j )
143 30 CONTINUE
144 40 CONTINUE
145*
146 ELSE
147 DO 60 j = 1, n
148 DO 50 i = 1, m
149 b( i, j ) = a( i, j )
150 50 CONTINUE
151 60 CONTINUE
152 END IF
153*
154 RETURN
155*
156* End of CLACP2
157*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53

◆ clacpy()

subroutine clacpy ( character uplo,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb )

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

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

Purpose:
!>
!> CLACPY copies all or part of a two-dimensional matrix A to another
!> matrix B.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies the part of the matrix A to be copied to B.
!>          = 'U':      Upper triangular part
!>          = 'L':      Lower triangular part
!>          Otherwise:  All of the matrix A
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
!>          is accessed; if UPLO = 'L', only the lower trapezium is
!>          accessed.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>          On exit, B = A in the locations specified by UPLO.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 102 of file clacpy.f.

103*
104* -- LAPACK auxiliary routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 CHARACTER UPLO
110 INTEGER LDA, LDB, M, N
111* ..
112* .. Array Arguments ..
113 COMPLEX A( LDA, * ), B( LDB, * )
114* ..
115*
116* =====================================================================
117*
118* .. Local Scalars ..
119 INTEGER I, J
120* ..
121* .. External Functions ..
122 LOGICAL LSAME
123 EXTERNAL lsame
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC min
127* ..
128* .. Executable Statements ..
129*
130 IF( lsame( uplo, 'U' ) ) THEN
131 DO 20 j = 1, n
132 DO 10 i = 1, min( j, m )
133 b( i, j ) = a( i, j )
134 10 CONTINUE
135 20 CONTINUE
136*
137 ELSE IF( lsame( uplo, 'L' ) ) THEN
138 DO 40 j = 1, n
139 DO 30 i = j, m
140 b( i, j ) = a( i, j )
141 30 CONTINUE
142 40 CONTINUE
143*
144 ELSE
145 DO 60 j = 1, n
146 DO 50 i = 1, m
147 b( i, j ) = a( i, j )
148 50 CONTINUE
149 60 CONTINUE
150 END IF
151*
152 RETURN
153*
154* End of CLACPY
155*

◆ clacrm()

subroutine clacrm ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork )

CLACRM multiplies a complex matrix by a square real matrix.

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

Purpose:
!>
!> CLACRM performs a very simple matrix-matrix multiplication:
!>          C := A * B,
!> where A is M by N and complex; B is N by N and real;
!> C is M by N and complex.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A and of the matrix C.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns and rows of the matrix B and
!>          the number of columns of the matrix C.
!>          N >= 0.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA, N)
!>          On entry, A contains the M by N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >=max(1,M).
!>
[in]B
!>          B is REAL array, dimension (LDB, N)
!>          On entry, B contains the N by N matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >=max(1,N).
!>
[out]C
!>          C is COMPLEX array, dimension (LDC, N)
!>          On exit, C contains the M by N matrix C.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >=max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*M*N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file clacrm.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 INTEGER LDA, LDB, LDC, M, N
121* ..
122* .. Array Arguments ..
123 REAL B( LDB, * ), RWORK( * )
124 COMPLEX A( LDA, * ), C( LDC, * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 REAL ONE, ZERO
131 parameter( one = 1.0e0, zero = 0.0e0 )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC aimag, cmplx, real
138* ..
139* .. External Subroutines ..
140 EXTERNAL sgemm
141* ..
142* .. Executable Statements ..
143*
144* Quick return if possible.
145*
146 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
147 $ RETURN
148*
149 DO 20 j = 1, n
150 DO 10 i = 1, m
151 rwork( ( j-1 )*m+i ) = real( a( i, j ) )
152 10 CONTINUE
153 20 CONTINUE
154*
155 l = m*n + 1
156 CALL sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,
157 $ rwork( l ), m )
158 DO 40 j = 1, n
159 DO 30 i = 1, m
160 c( i, j ) = rwork( l+( j-1 )*m+i-1 )
161 30 CONTINUE
162 40 CONTINUE
163*
164 DO 60 j = 1, n
165 DO 50 i = 1, m
166 rwork( ( j-1 )*m+i ) = aimag( a( i, j ) )
167 50 CONTINUE
168 60 CONTINUE
169 CALL sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,
170 $ rwork( l ), m )
171 DO 80 j = 1, n
172 DO 70 i = 1, m
173 c( i, j ) = cmplx( real( c( i, j ) ),
174 $ rwork( l+( j-1 )*m+i-1 ) )
175 70 CONTINUE
176 80 CONTINUE
177*
178 RETURN
179*
180* End of CLACRM
181*
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ clacrt()

subroutine clacrt ( integer n,
complex, dimension( * ) cx,
integer incx,
complex, dimension( * ) cy,
integer incy,
complex c,
complex s )

CLACRT performs a linear transformation of a pair of complex vectors.

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

Purpose:
!>
!> CLACRT performs the operation
!>
!>    (  c  s )( x )  ==> ( x )
!>    ( -s  c )( y )      ( y )
!>
!> where c and s are complex and the vectors x and y are complex.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of elements in the vectors CX and CY.
!>
[in,out]CX
!>          CX is COMPLEX array, dimension (N)
!>          On input, the vector x.
!>          On output, CX is overwritten with c*x + s*y.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between successive values of CX.  INCX <> 0.
!>
[in,out]CY
!>          CY is COMPLEX array, dimension (N)
!>          On input, the vector y.
!>          On output, CY is overwritten with -s*x + c*y.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between successive values of CY.  INCY <> 0.
!>
[in]C
!>          C is COMPLEX
!>
[in]S
!>          S is COMPLEX
!>          C and S define the matrix
!>             [  C   S  ].
!>             [ -S   C  ]
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 104 of file clacrt.f.

105*
106* -- LAPACK auxiliary routine --
107* -- LAPACK is a software package provided by Univ. of Tennessee, --
108* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
109*
110* .. Scalar Arguments ..
111 INTEGER INCX, INCY, N
112 COMPLEX C, S
113* ..
114* .. Array Arguments ..
115 COMPLEX CX( * ), CY( * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, IX, IY
122 COMPLEX CTEMP
123* ..
124* .. Executable Statements ..
125*
126 IF( n.LE.0 )
127 $ RETURN
128 IF( incx.EQ.1 .AND. incy.EQ.1 )
129 $ GO TO 20
130*
131* Code for unequal increments or equal increments not equal to 1
132*
133 ix = 1
134 iy = 1
135 IF( incx.LT.0 )
136 $ ix = ( -n+1 )*incx + 1
137 IF( incy.LT.0 )
138 $ iy = ( -n+1 )*incy + 1
139 DO 10 i = 1, n
140 ctemp = c*cx( ix ) + s*cy( iy )
141 cy( iy ) = c*cy( iy ) - s*cx( ix )
142 cx( ix ) = ctemp
143 ix = ix + incx
144 iy = iy + incy
145 10 CONTINUE
146 RETURN
147*
148* Code for both increments equal to 1
149*
150 20 CONTINUE
151 DO 30 i = 1, n
152 ctemp = c*cx( i ) + s*cy( i )
153 cy( i ) = c*cy( i ) - s*cx( i )
154 cx( i ) = ctemp
155 30 CONTINUE
156 RETURN

◆ cladiv()

complex function cladiv ( complex x,
complex y )

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

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

Purpose:
!>
!> CLADIV := X / Y, where X and Y are complex.  The computation of X / Y
!> will not overflow on an intermediary step unless the results
!> overflows.
!>
Parameters
[in]X
!>          X is COMPLEX
!>
[in]Y
!>          Y is COMPLEX
!>          The complex scalars X and Y.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 63 of file cladiv.f.

64*
65* -- LAPACK auxiliary routine --
66* -- LAPACK is a software package provided by Univ. of Tennessee, --
67* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
68*
69* .. Scalar Arguments ..
70 COMPLEX X, Y
71* ..
72*
73* =====================================================================
74*
75* .. Local Scalars ..
76 REAL ZI, ZR
77* ..
78* .. External Subroutines ..
79 EXTERNAL sladiv
80* ..
81* .. Intrinsic Functions ..
82 INTRINSIC aimag, cmplx, real
83* ..
84* .. Executable Statements ..
85*
86 CALL sladiv( real( x ), aimag( x ), real( y ), aimag( y ), zr,
87 $ zi )
88 cladiv = cmplx( zr, zi )
89*
90 RETURN
91*
92* End of CLADIV
93*
cladiv
complex function cladiv(x, y)
CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition cladiv.f:64
sladiv
subroutine sladiv(a, b, c, d, p, q)
SLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition sladiv.f:91

◆ claein()

subroutine claein ( logical rightv,
logical noinit,
integer n,
complex, dimension( ldh, * ) h,
integer ldh,
complex w,
complex, dimension( * ) v,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real eps3,
real smlnum,
integer info )

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

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

Purpose:
!>
!> CLAEIN uses inverse iteration to find a right or left eigenvector
!> corresponding to the eigenvalue W of a complex 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 V
!>          = .FALSE.: initial vector supplied in V.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix H.  N >= 0.
!>
[in]H
!>          H is COMPLEX 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]W
!>          W is COMPLEX
!>          The eigenvalue of H whose corresponding right or left
!>          eigenvector is to be computed.
!>
[in,out]V
!>          V is COMPLEX array, dimension (N)
!>          On entry, if NOINIT = .FALSE., V must contain a starting
!>          vector for inverse iteration; otherwise V need not be set.
!>          On exit, V contains the computed eigenvector, 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|.
!>
[out]B
!>          B is COMPLEX array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[in]EPS3
!>          EPS3 is REAL
!>          A small machine-dependent value which is used to perturb
!>          close eigenvalues, and to replace zero pivots.
!>
[in]SMLNUM
!>          SMLNUM is REAL
!>          A machine-dependent value close to the underflow threshold.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          = 1:  inverse iteration did not converge; V is set to the
!>                last iterate.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file claein.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 LOGICAL NOINIT, RIGHTV
156 INTEGER INFO, LDB, LDH, N
157 REAL EPS3, SMLNUM
158 COMPLEX W
159* ..
160* .. Array Arguments ..
161 REAL RWORK( * )
162 COMPLEX B( LDB, * ), H( LDH, * ), V( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 REAL ONE, TENTH
169 parameter( one = 1.0e+0, tenth = 1.0e-1 )
170 COMPLEX ZERO
171 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
172* ..
173* .. Local Scalars ..
174 CHARACTER NORMIN, TRANS
175 INTEGER I, IERR, ITS, J
176 REAL GROWTO, NRMSML, ROOTN, RTEMP, SCALE, VNORM
177 COMPLEX CDUM, EI, EJ, TEMP, X
178* ..
179* .. External Functions ..
180 INTEGER ICAMAX
181 REAL SCASUM, SCNRM2
182 COMPLEX CLADIV
183 EXTERNAL icamax, scasum, scnrm2, cladiv
184* ..
185* .. External Subroutines ..
186 EXTERNAL clatrs, csscal
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC abs, aimag, max, real, sqrt
190* ..
191* .. Statement Functions ..
192 REAL CABS1
193* ..
194* .. Statement Function definitions ..
195 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
196* ..
197* .. Executable Statements ..
198*
199 info = 0
200*
201* GROWTO is the threshold used in the acceptance test for an
202* eigenvector.
203*
204 rootn = sqrt( real( n ) )
205 growto = tenth / rootn
206 nrmsml = max( one, eps3*rootn )*smlnum
207*
208* Form B = H - W*I (except that the subdiagonal elements are not
209* stored).
210*
211 DO 20 j = 1, n
212 DO 10 i = 1, j - 1
213 b( i, j ) = h( i, j )
214 10 CONTINUE
215 b( j, j ) = h( j, j ) - w
216 20 CONTINUE
217*
218 IF( noinit ) THEN
219*
220* Initialize V.
221*
222 DO 30 i = 1, n
223 v( i ) = eps3
224 30 CONTINUE
225 ELSE
226*
227* Scale supplied initial vector.
228*
229 vnorm = scnrm2( n, v, 1 )
230 CALL csscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), v, 1 )
231 END IF
232*
233 IF( rightv ) THEN
234*
235* LU decomposition with partial pivoting of B, replacing zero
236* pivots by EPS3.
237*
238 DO 60 i = 1, n - 1
239 ei = h( i+1, i )
240 IF( cabs1( b( i, i ) ).LT.cabs1( ei ) ) THEN
241*
242* Interchange rows and eliminate.
243*
244 x = cladiv( b( i, i ), ei )
245 b( i, i ) = ei
246 DO 40 j = i + 1, n
247 temp = b( i+1, j )
248 b( i+1, j ) = b( i, j ) - x*temp
249 b( i, j ) = temp
250 40 CONTINUE
251 ELSE
252*
253* Eliminate without interchange.
254*
255 IF( b( i, i ).EQ.zero )
256 $ b( i, i ) = eps3
257 x = cladiv( ei, b( i, i ) )
258 IF( x.NE.zero ) THEN
259 DO 50 j = i + 1, n
260 b( i+1, j ) = b( i+1, j ) - x*b( i, j )
261 50 CONTINUE
262 END IF
263 END IF
264 60 CONTINUE
265 IF( b( n, n ).EQ.zero )
266 $ b( n, n ) = eps3
267*
268 trans = 'N'
269*
270 ELSE
271*
272* UL decomposition with partial pivoting of B, replacing zero
273* pivots by EPS3.
274*
275 DO 90 j = n, 2, -1
276 ej = h( j, j-1 )
277 IF( cabs1( b( j, j ) ).LT.cabs1( ej ) ) THEN
278*
279* Interchange columns and eliminate.
280*
281 x = cladiv( b( j, j ), ej )
282 b( j, j ) = ej
283 DO 70 i = 1, j - 1
284 temp = b( i, j-1 )
285 b( i, j-1 ) = b( i, j ) - x*temp
286 b( i, j ) = temp
287 70 CONTINUE
288 ELSE
289*
290* Eliminate without interchange.
291*
292 IF( b( j, j ).EQ.zero )
293 $ b( j, j ) = eps3
294 x = cladiv( ej, b( j, j ) )
295 IF( x.NE.zero ) THEN
296 DO 80 i = 1, j - 1
297 b( i, j-1 ) = b( i, j-1 ) - x*b( i, j )
298 80 CONTINUE
299 END IF
300 END IF
301 90 CONTINUE
302 IF( b( 1, 1 ).EQ.zero )
303 $ b( 1, 1 ) = eps3
304*
305 trans = 'C'
306*
307 END IF
308*
309 normin = 'N'
310 DO 110 its = 1, n
311*
312* Solve U*x = scale*v for a right eigenvector
313* or U**H *x = scale*v for a left eigenvector,
314* overwriting x on v.
315*
316 CALL clatrs( 'Upper', trans, 'Nonunit', normin, n, b, ldb, v,
317 $ scale, rwork, ierr )
318 normin = 'Y'
319*
320* Test for sufficient growth in the norm of v.
321*
322 vnorm = scasum( n, v, 1 )
323 IF( vnorm.GE.growto*scale )
324 $ GO TO 120
325*
326* Choose new orthogonal starting vector and try again.
327*
328 rtemp = eps3 / ( rootn+one )
329 v( 1 ) = eps3
330 DO 100 i = 2, n
331 v( i ) = rtemp
332 100 CONTINUE
333 v( n-its+1 ) = v( n-its+1 ) - eps3*rootn
334 110 CONTINUE
335*
336* Failure to find eigenvector in N iterations.
337*
338 info = 1
339*
340 120 CONTINUE
341*
342* Normalize eigenvector.
343*
344 i = icamax( n, v, 1 )
345 CALL csscal( n, one / cabs1( v( i ) ), v, 1 )
346*
347 RETURN
348*
349* End of CLAEIN
350*
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71
clatrs
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition clatrs.f:239
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
scasum
real function scasum(n, cx, incx)
SCASUM
Definition scasum.f:72
scnrm2
real(wp) function scnrm2(n, x, incx)
SCNRM2
Definition scnrm2.f90:90
max
#define max(a, b)
Definition macros.h:21

◆ claev2()

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

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

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

Purpose:
!>
!> CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
!>    [  A         B  ]
!>    [  CONJG(B)  C  ].
!> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
!> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
!> eigenvector for RT1, giving the decomposition
!>
!> [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
!> [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
!>
Parameters
[in]A
!>          A is COMPLEX
!>         The (1,1) element of the 2-by-2 matrix.
!>
[in]B
!>          B is COMPLEX
!>         The (1,2) element and the conjugate of the (2,1) element of
!>         the 2-by-2 matrix.
!>
[in]C
!>          C is COMPLEX
!>         The (2,2) element of the 2-by-2 matrix.
!>
[out]RT1
!>          RT1 is REAL
!>         The eigenvalue of larger absolute value.
!>
[out]RT2
!>          RT2 is REAL
!>         The eigenvalue of smaller absolute value.
!>
[out]CS1
!>          CS1 is REAL
!>
[out]SN1
!>          SN1 is COMPLEX
!>         The vector (CS1, SN1) is a unit right eigenvector for RT1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  RT1 is accurate to a few ulps barring over/underflow.
!>
!>  RT2 may be inaccurate if there is massive cancellation in the
!>  determinant A*C-B*B; higher precision or correctly rounded or
!>  correctly truncated arithmetic would be needed to compute RT2
!>  accurately in all cases.
!>
!>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
!>
!>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
!>  Underflow is harmless if the input data is 0 or exceeds
!>     underflow_threshold / macheps.
!>

Definition at line 120 of file claev2.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 REAL CS1, RT1, RT2
128 COMPLEX A, B, C, SN1
129* ..
130*
131* =====================================================================
132*
133* .. Parameters ..
134 REAL ZERO
135 parameter( zero = 0.0e0 )
136 REAL ONE
137 parameter( one = 1.0e0 )
138* ..
139* .. Local Scalars ..
140 REAL T
141 COMPLEX W
142* ..
143* .. External Subroutines ..
144 EXTERNAL slaev2
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, conjg, real
148* ..
149* .. Executable Statements ..
150*
151 IF( abs( b ).EQ.zero ) THEN
152 w = one
153 ELSE
154 w = conjg( b ) / abs( b )
155 END IF
156 CALL slaev2( real( a ), abs( b ), real( c ), rt1, rt2, cs1, t )
157 sn1 = w*t
158 RETURN
159*
160* End of CLAEV2
161*
slaev2
subroutine slaev2(a, b, c, rt1, rt2, cs1, sn1)
SLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition slaev2.f:120

◆ clags2()

subroutine clags2 ( logical upper,
real a1,
complex a2,
real a3,
real b1,
complex b2,
real b3,
real csu,
complex snu,
real csv,
complex snv,
real csq,
complex snq )

CLAGS2

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

Purpose:
!>
!> CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such
!> that if ( UPPER ) then
!>
!>           U**H *A*Q = U**H *( A1 A2 )*Q = ( x  0  )
!>                             ( 0  A3 )     ( x  x  )
!> and
!>           V**H*B*Q = V**H *( B1 B2 )*Q = ( x  0  )
!>                            ( 0  B3 )     ( x  x  )
!>
!> or if ( .NOT.UPPER ) then
!>
!>           U**H *A*Q = U**H *( A1 0  )*Q = ( x  x  )
!>                             ( A2 A3 )     ( 0  x  )
!> and
!>           V**H *B*Q = V**H *( B1 0  )*Q = ( x  x  )
!>                             ( B2 B3 )     ( 0  x  )
!> where
!>
!>   U = (   CSU    SNU ), V = (  CSV    SNV ),
!>       ( -SNU**H  CSU )      ( -SNV**H CSV )
!>
!>   Q = (   CSQ    SNQ )
!>       ( -SNQ**H  CSQ )
!>
!> The rows of the transformed A and B are parallel. Moreover, if the
!> input 2-by-2 matrix A is not zero, then the transformed (1,1) entry
!> of A is not zero. If the input matrices A and B are both not zero,
!> then the transformed (2,2) element of B is not zero, except when the
!> first rows of input A and B are parallel and the second rows are
!> zero.
!>
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 REAL
!>
[in]A2
!>          A2 is COMPLEX
!>
[in]A3
!>          A3 is REAL
!>          On entry, A1, A2 and A3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix A.
!>
[in]B1
!>          B1 is REAL
!>
[in]B2
!>          B2 is COMPLEX
!>
[in]B3
!>          B3 is REAL
!>          On entry, B1, B2 and B3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix B.
!>
[out]CSU
!>          CSU is REAL
!>
[out]SNU
!>          SNU is COMPLEX
!>          The desired unitary matrix U.
!>
[out]CSV
!>          CSV is REAL
!>
[out]SNV
!>          SNV is COMPLEX
!>          The desired unitary matrix V.
!>
[out]CSQ
!>          CSQ is REAL
!>
[out]SNQ
!>          SNQ is COMPLEX
!>          The desired unitary matrix Q.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file clags2.f.

158*
159* -- LAPACK auxiliary routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163* .. Scalar Arguments ..
164 LOGICAL UPPER
165 REAL A1, A3, B1, B3, CSQ, CSU, CSV
166 COMPLEX A2, B2, SNQ, SNU, SNV
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 REAL ZERO, ONE
173 parameter( zero = 0.0e+0, one = 1.0e+0 )
174* ..
175* .. Local Scalars ..
176 REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
177 $ AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2, SNL,
178 $ SNR, UA11R, UA22R, VB11R, VB22R
179 COMPLEX B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
180 $ VB12, VB21, VB22
181* ..
182* .. External Subroutines ..
183 EXTERNAL clartg, slasv2
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, aimag, cmplx, conjg, real
187* ..
188* .. Statement Functions ..
189 REAL ABS1
190* ..
191* .. Statement Function definitions ..
192 abs1( t ) = abs( real( t ) ) + abs( aimag( t ) )
193* ..
194* .. Executable Statements ..
195*
196 IF( upper ) THEN
197*
198* Input matrices A and B are upper triangular matrices
199*
200* Form matrix C = A*adj(B) = ( a b )
201* ( 0 d )
202*
203 a = a1*b3
204 d = a3*b1
205 b = a2*b1 - a1*b2
206 fb = abs( b )
207*
208* Transform complex 2-by-2 matrix C to real matrix by unitary
209* diagonal matrix diag(1,D1).
210*
211 d1 = one
212 IF( fb.NE.zero )
213 $ d1 = b / fb
214*
215* The SVD of real 2 by 2 triangular C
216*
217* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
218* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
219*
220 CALL slasv2( a, fb, d, s1, s2, snr, csr, snl, csl )
221*
222 IF( abs( csl ).GE.abs( snl ) .OR. abs( csr ).GE.abs( snr ) )
223 $ THEN
224*
225* Compute the (1,1) and (1,2) elements of U**H *A and V**H *B,
226* and (1,2) element of |U|**H *|A| and |V|**H *|B|.
227*
228 ua11r = csl*a1
229 ua12 = csl*a2 + d1*snl*a3
230*
231 vb11r = csr*b1
232 vb12 = csr*b2 + d1*snr*b3
233*
234 aua12 = abs( csl )*abs1( a2 ) + abs( snl )*abs( a3 )
235 avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 )
236*
237* zero (1,2) elements of U**H *A and V**H *B
238*
239 IF( ( abs( ua11r )+abs1( ua12 ) ).EQ.zero ) THEN
240 CALL clartg( -cmplx( vb11r ), conjg( vb12 ), csq, snq,
241 $ r )
242 ELSE IF( ( abs( vb11r )+abs1( vb12 ) ).EQ.zero ) THEN
243 CALL clartg( -cmplx( ua11r ), conjg( ua12 ), csq, snq,
244 $ r )
245 ELSE IF( aua12 / ( abs( ua11r )+abs1( ua12 ) ).LE.avb12 /
246 $ ( abs( vb11r )+abs1( vb12 ) ) ) THEN
247 CALL clartg( -cmplx( ua11r ), conjg( ua12 ), csq, snq,
248 $ r )
249 ELSE
250 CALL clartg( -cmplx( vb11r ), conjg( vb12 ), csq, snq,
251 $ r )
252 END IF
253*
254 csu = csl
255 snu = -d1*snl
256 csv = csr
257 snv = -d1*snr
258*
259 ELSE
260*
261* Compute the (2,1) and (2,2) elements of U**H *A and V**H *B,
262* and (2,2) element of |U|**H *|A| and |V|**H *|B|.
263*
264 ua21 = -conjg( d1 )*snl*a1
265 ua22 = -conjg( d1 )*snl*a2 + csl*a3
266*
267 vb21 = -conjg( d1 )*snr*b1
268 vb22 = -conjg( d1 )*snr*b2 + csr*b3
269*
270 aua22 = abs( snl )*abs1( a2 ) + abs( csl )*abs( a3 )
271 avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 )
272*
273* zero (2,2) elements of U**H *A and V**H *B, and then swap.
274*
275 IF( ( abs1( ua21 )+abs1( ua22 ) ).EQ.zero ) THEN
276 CALL clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r )
277 ELSE IF( ( abs1( vb21 )+abs( vb22 ) ).EQ.zero ) THEN
278 CALL clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r )
279 ELSE IF( aua22 / ( abs1( ua21 )+abs1( ua22 ) ).LE.avb22 /
280 $ ( abs1( vb21 )+abs1( vb22 ) ) ) THEN
281 CALL clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r )
282 ELSE
283 CALL clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r )
284 END IF
285*
286 csu = snl
287 snu = d1*csl
288 csv = snr
289 snv = d1*csr
290*
291 END IF
292*
293 ELSE
294*
295* Input matrices A and B are lower triangular matrices
296*
297* Form matrix C = A*adj(B) = ( a 0 )
298* ( c d )
299*
300 a = a1*b3
301 d = a3*b1
302 c = a2*b3 - a3*b2
303 fc = abs( c )
304*
305* Transform complex 2-by-2 matrix C to real matrix by unitary
306* diagonal matrix diag(d1,1).
307*
308 d1 = one
309 IF( fc.NE.zero )
310 $ d1 = c / fc
311*
312* The SVD of real 2 by 2 triangular C
313*
314* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
315* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
316*
317 CALL slasv2( a, fc, d, s1, s2, snr, csr, snl, csl )
318*
319 IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
320 $ THEN
321*
322* Compute the (2,1) and (2,2) elements of U**H *A and V**H *B,
323* and (2,1) element of |U|**H *|A| and |V|**H *|B|.
324*
325 ua21 = -d1*snr*a1 + csr*a2
326 ua22r = csr*a3
327*
328 vb21 = -d1*snl*b1 + csl*b2
329 vb22r = csl*b3
330*
331 aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs1( a2 )
332 avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 )
333*
334* zero (2,1) elements of U**H *A and V**H *B.
335*
336 IF( ( abs1( ua21 )+abs( ua22r ) ).EQ.zero ) THEN
337 CALL clartg( cmplx( vb22r ), vb21, csq, snq, r )
338 ELSE IF( ( abs1( vb21 )+abs( vb22r ) ).EQ.zero ) THEN
339 CALL clartg( cmplx( ua22r ), ua21, csq, snq, r )
340 ELSE IF( aua21 / ( abs1( ua21 )+abs( ua22r ) ).LE.avb21 /
341 $ ( abs1( vb21 )+abs( vb22r ) ) ) THEN
342 CALL clartg( cmplx( ua22r ), ua21, csq, snq, r )
343 ELSE
344 CALL clartg( cmplx( vb22r ), vb21, csq, snq, r )
345 END IF
346*
347 csu = csr
348 snu = -conjg( d1 )*snr
349 csv = csl
350 snv = -conjg( d1 )*snl
351*
352 ELSE
353*
354* Compute the (1,1) and (1,2) elements of U**H *A and V**H *B,
355* and (1,1) element of |U|**H *|A| and |V|**H *|B|.
356*
357 ua11 = csr*a1 + conjg( d1 )*snr*a2
358 ua12 = conjg( d1 )*snr*a3
359*
360 vb11 = csl*b1 + conjg( d1 )*snl*b2
361 vb12 = conjg( d1 )*snl*b3
362*
363 aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs1( a2 )
364 avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 )
365*
366* zero (1,1) elements of U**H *A and V**H *B, and then swap.
367*
368 IF( ( abs1( ua11 )+abs1( ua12 ) ).EQ.zero ) THEN
369 CALL clartg( vb12, vb11, csq, snq, r )
370 ELSE IF( ( abs1( vb11 )+abs1( vb12 ) ).EQ.zero ) THEN
371 CALL clartg( ua12, ua11, csq, snq, r )
372 ELSE IF( aua11 / ( abs1( ua11 )+abs1( ua12 ) ).LE.avb11 /
373 $ ( abs1( vb11 )+abs1( vb12 ) ) ) THEN
374 CALL clartg( ua12, ua11, csq, snq, r )
375 ELSE
376 CALL clartg( vb12, vb11, csq, snq, r )
377 END IF
378*
379 csu = snr
380 snu = conjg( d1 )*csr
381 csv = snl
382 snv = conjg( d1 )*csl
383*
384 END IF
385*
386 END IF
387*
388 RETURN
389*
390* End of CLAGS2
391*
slasv2
subroutine slasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition slasv2.f:138
clartg
subroutine clartg(f, g, c, s, r)
CLARTG generates a plane rotation with real cosine and complex sine.
Definition clartg.f90:118

◆ clagtm()

subroutine clagtm ( character trans,
integer n,
integer nrhs,
real alpha,
complex, dimension( * ) dl,
complex, dimension( * ) d,
complex, dimension( * ) du,
complex, dimension( ldx, * ) x,
integer ldx,
real beta,
complex, dimension( ldb, * ) b,
integer ldb )

CLAGTM 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 CLAGTM + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLAGTM 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**T * X + beta * B
!>          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B
!>
[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 REAL
!>          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]DL
!>          DL is COMPLEX array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of T.
!>
[in]D
!>          D is COMPLEX array, dimension (N)
!>          The diagonal elements of T.
!>
[in]DU
!>          DU is COMPLEX array, dimension (N-1)
!>          The (n-1) super-diagonal elements of T.
!>
[in]X
!>          X is COMPLEX 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 REAL
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is COMPLEX 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 clagtm.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 REAL ALPHA, BETA
154* ..
155* .. Array Arguments ..
156 COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ),
157 $ X( LDX, * )
158* ..
159*
160* =====================================================================
161*
162* .. Parameters ..
163 REAL ONE, ZERO
164 parameter( one = 1.0e+0, zero = 0.0e+0 )
165* ..
166* .. Local Scalars ..
167 INTEGER I, J
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC conjg
175* ..
176* .. Executable Statements ..
177*
178 IF( n.EQ.0 )
179 $ RETURN
180*
181* Multiply B by BETA if BETA.NE.1.
182*
183 IF( beta.EQ.zero ) THEN
184 DO 20 j = 1, nrhs
185 DO 10 i = 1, n
186 b( i, j ) = zero
187 10 CONTINUE
188 20 CONTINUE
189 ELSE IF( beta.EQ.-one ) THEN
190 DO 40 j = 1, nrhs
191 DO 30 i = 1, n
192 b( i, j ) = -b( i, j )
193 30 CONTINUE
194 40 CONTINUE
195 END IF
196*
197 IF( alpha.EQ.one ) THEN
198 IF( lsame( trans, 'N' ) ) THEN
199*
200* Compute B := B + A*X
201*
202 DO 60 j = 1, nrhs
203 IF( n.EQ.1 ) THEN
204 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
205 ELSE
206 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
207 $ du( 1 )*x( 2, j )
208 b( n, j ) = b( n, j ) + dl( n-1 )*x( n-1, j ) +
209 $ d( n )*x( n, j )
210 DO 50 i = 2, n - 1
211 b( i, j ) = b( i, j ) + dl( i-1 )*x( i-1, j ) +
212 $ d( i )*x( i, j ) + du( i )*x( i+1, j )
213 50 CONTINUE
214 END IF
215 60 CONTINUE
216 ELSE IF( lsame( trans, 'T' ) ) THEN
217*
218* Compute B := B + A**T * X
219*
220 DO 80 j = 1, nrhs
221 IF( n.EQ.1 ) THEN
222 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
223 ELSE
224 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
225 $ dl( 1 )*x( 2, j )
226 b( n, j ) = b( n, j ) + du( n-1 )*x( n-1, j ) +
227 $ d( n )*x( n, j )
228 DO 70 i = 2, n - 1
229 b( i, j ) = b( i, j ) + du( i-1 )*x( i-1, j ) +
230 $ d( i )*x( i, j ) + dl( i )*x( i+1, j )
231 70 CONTINUE
232 END IF
233 80 CONTINUE
234 ELSE IF( lsame( trans, 'C' ) ) THEN
235*
236* Compute B := B + A**H * X
237*
238 DO 100 j = 1, nrhs
239 IF( n.EQ.1 ) THEN
240 b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j )
241 ELSE
242 b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) +
243 $ conjg( dl( 1 ) )*x( 2, j )
244 b( n, j ) = b( n, j ) + conjg( du( n-1 ) )*
245 $ x( n-1, j ) + conjg( d( n ) )*x( n, j )
246 DO 90 i = 2, n - 1
247 b( i, j ) = b( i, j ) + conjg( du( i-1 ) )*
248 $ x( i-1, j ) + conjg( d( i ) )*
249 $ x( i, j ) + conjg( dl( i ) )*
250 $ x( i+1, j )
251 90 CONTINUE
252 END IF
253 100 CONTINUE
254 END IF
255 ELSE IF( alpha.EQ.-one ) THEN
256 IF( lsame( trans, 'N' ) ) THEN
257*
258* Compute B := B - A*X
259*
260 DO 120 j = 1, nrhs
261 IF( n.EQ.1 ) THEN
262 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
263 ELSE
264 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
265 $ du( 1 )*x( 2, j )
266 b( n, j ) = b( n, j ) - dl( n-1 )*x( n-1, j ) -
267 $ d( n )*x( n, j )
268 DO 110 i = 2, n - 1
269 b( i, j ) = b( i, j ) - dl( i-1 )*x( i-1, j ) -
270 $ d( i )*x( i, j ) - du( i )*x( i+1, j )
271 110 CONTINUE
272 END IF
273 120 CONTINUE
274 ELSE IF( lsame( trans, 'T' ) ) THEN
275*
276* Compute B := B - A**T*X
277*
278 DO 140 j = 1, nrhs
279 IF( n.EQ.1 ) THEN
280 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
281 ELSE
282 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
283 $ dl( 1 )*x( 2, j )
284 b( n, j ) = b( n, j ) - du( n-1 )*x( n-1, j ) -
285 $ d( n )*x( n, j )
286 DO 130 i = 2, n - 1
287 b( i, j ) = b( i, j ) - du( i-1 )*x( i-1, j ) -
288 $ d( i )*x( i, j ) - dl( i )*x( i+1, j )
289 130 CONTINUE
290 END IF
291 140 CONTINUE
292 ELSE IF( lsame( trans, 'C' ) ) THEN
293*
294* Compute B := B - A**H*X
295*
296 DO 160 j = 1, nrhs
297 IF( n.EQ.1 ) THEN
298 b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j )
299 ELSE
300 b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) -
301 $ conjg( dl( 1 ) )*x( 2, j )
302 b( n, j ) = b( n, j ) - conjg( du( n-1 ) )*
303 $ x( n-1, j ) - conjg( d( n ) )*x( n, j )
304 DO 150 i = 2, n - 1
305 b( i, j ) = b( i, j ) - conjg( du( i-1 ) )*
306 $ x( i-1, j ) - conjg( d( i ) )*
307 $ x( i, j ) - conjg( dl( i ) )*
308 $ x( i+1, j )
309 150 CONTINUE
310 END IF
311 160 CONTINUE
312 END IF
313 END IF
314 RETURN
315*
316* End of CLAGTM
317*

◆ clahqr()

subroutine clahqr ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( * ) w,
integer iloz,
integer ihiz,
complex, dimension( ldz, * ) z,
integer ldz,
integer info )

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

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

Purpose:
!>
!>    CLAHQR is an auxiliary routine called by CHSEQR to update the
!>    eigenvalues and Schur decomposition already computed by CHSEQR, 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 triangular in rows and
!>          columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
!>          CLAHQR 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 COMPLEX array, dimension (LDH,N)
!>          On entry, the upper Hessenberg matrix H.
!>          On exit, if INFO is zero and if WANTT is .TRUE., then H
!>          is upper triangular in rows and columns ILO:IHI.  If INFO
!>          is zero and if WANTT is .FALSE., then the contents of H
!>          are unspecified on exit.  The output state of H in case
!>          INF is positive is below under the description of INFO.
!>
[in]LDH
!>          LDH is INTEGER
!>          The leading dimension of the array H. LDH >= max(1,N).
!>
[out]W
!>          W is COMPLEX array, dimension (N)
!>          The computed eigenvalues ILO to IHI are stored in the
!>          corresponding elements of W. If WANTT is .TRUE., the
!>          eigenvalues are stored in the same order as on the diagonal
!>          of the Schur form returned in H, with W(i) = H(i,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 COMPLEX array, dimension (LDZ,N)
!>          If WANTZ is .TRUE., on entry Z must contain the current
!>          matrix Z of transformations accumulated by CHSEQR, 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, CLAHQR failed to compute all the
!>                  eigenvalues ILO to IHI in a total of 30 iterations
!>                  per eigenvalue; elements i+1:ihi of W 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.
Contributors:
!>
!>     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 CLAHQR 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 193 of file clahqr.f.

195 IMPLICIT NONE
196*
197* -- LAPACK auxiliary routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
203 LOGICAL WANTT, WANTZ
204* ..
205* .. Array Arguments ..
206 COMPLEX H( LDH, * ), W( * ), Z( LDZ, * )
207* ..
208*
209* =========================================================
210*
211* .. Parameters ..
212 COMPLEX ZERO, ONE
213 parameter( zero = ( 0.0e0, 0.0e0 ),
214 $ one = ( 1.0e0, 0.0e0 ) )
215 REAL RZERO, RONE, HALF
216 parameter( rzero = 0.0e0, rone = 1.0e0, half = 0.5e0 )
217 REAL DAT1
218 parameter( dat1 = 3.0e0 / 4.0e0 )
219 INTEGER KEXSH
220 parameter( kexsh = 10 )
221* ..
222* .. Local Scalars ..
223 COMPLEX CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
224 $ V2, X, Y
225 REAL AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
226 $ SAFMIN, SMLNUM, SX, T2, TST, ULP
227 INTEGER I, I1, I2, ITS, ITMAX, J, JHI, JLO, K, L, M,
228 $ NH, NZ, KDEFL
229* ..
230* .. Local Arrays ..
231 COMPLEX V( 2 )
232* ..
233* .. External Functions ..
234 COMPLEX CLADIV
235 REAL SLAMCH
236 EXTERNAL cladiv, slamch
237* ..
238* .. External Subroutines ..
239 EXTERNAL ccopy, clarfg, cscal, slabad
240* ..
241* .. Statement Functions ..
242 REAL CABS1
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC abs, aimag, conjg, max, min, real, sqrt
246* ..
247* .. Statement Function definitions ..
248 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
249* ..
250* .. Executable Statements ..
251*
252 info = 0
253*
254* Quick return if possible
255*
256 IF( n.EQ.0 )
257 $ RETURN
258 IF( ilo.EQ.ihi ) THEN
259 w( ilo ) = h( ilo, ilo )
260 RETURN
261 END IF
262*
263* ==== clear out the trash ====
264 DO 10 j = ilo, ihi - 3
265 h( j+2, j ) = zero
266 h( j+3, j ) = zero
267 10 CONTINUE
268 IF( ilo.LE.ihi-2 )
269 $ h( ihi, ihi-2 ) = zero
270* ==== ensure that subdiagonal entries are real ====
271 IF( wantt ) THEN
272 jlo = 1
273 jhi = n
274 ELSE
275 jlo = ilo
276 jhi = ihi
277 END IF
278 DO 20 i = ilo + 1, ihi
279 IF( aimag( h( i, i-1 ) ).NE.rzero ) THEN
280* ==== The following redundant normalization
281* . avoids problems with both gradual and
282* . sudden underflow in ABS(H(I,I-1)) ====
283 sc = h( i, i-1 ) / cabs1( h( i, i-1 ) )
284 sc = conjg( sc ) / abs( sc )
285 h( i, i-1 ) = abs( h( i, i-1 ) )
286 CALL cscal( jhi-i+1, sc, h( i, i ), ldh )
287 CALL cscal( min( jhi, i+1 )-jlo+1, conjg( sc ), h( jlo, i ),
288 $ 1 )
289 IF( wantz )
290 $ CALL cscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 )
291 END IF
292 20 CONTINUE
293*
294 nh = ihi - ilo + 1
295 nz = ihiz - iloz + 1
296*
297* Set machine-dependent constants for the stopping criterion.
298*
299 safmin = slamch( 'SAFE MINIMUM' )
300 safmax = rone / safmin
301 CALL slabad( safmin, safmax )
302 ulp = slamch( 'PRECISION' )
303 smlnum = safmin*( real( nh ) / ulp )
304*
305* I1 and I2 are the indices of the first row and last column of H
306* to which transformations must be applied. If eigenvalues only are
307* being computed, I1 and I2 are set inside the main loop.
308*
309 IF( wantt ) THEN
310 i1 = 1
311 i2 = n
312 END IF
313*
314* ITMAX is the total number of QR iterations allowed.
315*
316 itmax = 30 * max( 10, nh )
317*
318* KDEFL counts the number of iterations since a deflation
319*
320 kdefl = 0
321*
322* The main loop begins here. I is the loop index and decreases from
323* IHI to ILO in steps of 1. Each iteration of the loop works
324* with the active submatrix in rows and columns L to I.
325* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
326* H(L,L-1) is negligible so that the matrix splits.
327*
328 i = ihi
329 30 CONTINUE
330 IF( i.LT.ilo )
331 $ GO TO 150
332*
333* Perform QR iterations on rows and columns ILO to I until a
334* submatrix of order 1 splits off at the bottom because a
335* subdiagonal element has become negligible.
336*
337 l = ilo
338 DO 130 its = 0, itmax
339*
340* Look for a single small subdiagonal element.
341*
342 DO 40 k = i, l + 1, -1
343 IF( cabs1( h( k, k-1 ) ).LE.smlnum )
344 $ GO TO 50
345 tst = cabs1( h( k-1, k-1 ) ) + cabs1( h( k, k ) )
346 IF( tst.EQ.zero ) THEN
347 IF( k-2.GE.ilo )
348 $ tst = tst + abs( real( h( k-1, k-2 ) ) )
349 IF( k+1.LE.ihi )
350 $ tst = tst + abs( real( h( k+1, k ) ) )
351 END IF
352* ==== The following is a conservative small subdiagonal
353* . deflation criterion due to Ahues & Tisseur (LAWN 122,
354* . 1997). It has better mathematical foundation and
355* . improves accuracy in some examples. ====
356 IF( abs( real( h( k, k-1 ) ) ).LE.ulp*tst ) THEN
357 ab = max( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) )
358 ba = min( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) )
359 aa = max( cabs1( h( k, k ) ),
360 $ cabs1( h( k-1, k-1 )-h( k, k ) ) )
361 bb = min( cabs1( h( k, k ) ),
362 $ cabs1( h( k-1, k-1 )-h( k, k ) ) )
363 s = aa + ab
364 IF( ba*( ab / s ).LE.max( smlnum,
365 $ ulp*( bb*( aa / s ) ) ) )GO TO 50
366 END IF
367 40 CONTINUE
368 50 CONTINUE
369 l = k
370 IF( l.GT.ilo ) THEN
371*
372* H(L,L-1) is negligible
373*
374 h( l, l-1 ) = zero
375 END IF
376*
377* Exit from loop if a submatrix of order 1 has split off.
378*
379 IF( l.GE.i )
380 $ GO TO 140
381 kdefl = kdefl + 1
382*
383* Now the active submatrix is in rows and columns L to I. If
384* eigenvalues only are being computed, only the active submatrix
385* need be transformed.
386*
387 IF( .NOT.wantt ) THEN
388 i1 = l
389 i2 = i
390 END IF
391*
392 IF( mod(kdefl,2*kexsh).EQ.0 ) THEN
393*
394* Exceptional shift.
395*
396 s = dat1*abs( real( h( i, i-1 ) ) )
397 t = s + h( i, i )
398 ELSE IF( mod(kdefl,kexsh).EQ.0 ) THEN
399*
400* Exceptional shift.
401*
402 s = dat1*abs( real( h( l+1, l ) ) )
403 t = s + h( l, l )
404 ELSE
405*
406* Wilkinson's shift.
407*
408 t = h( i, i )
409 u = sqrt( h( i-1, i ) )*sqrt( h( i, i-1 ) )
410 s = cabs1( u )
411 IF( s.NE.rzero ) THEN
412 x = half*( h( i-1, i-1 )-t )
413 sx = cabs1( x )
414 s = max( s, cabs1( x ) )
415 y = s*sqrt( ( x / s )**2+( u / s )**2 )
416 IF( sx.GT.rzero ) THEN
417 IF( real( x / sx )*real( y )+aimag( x / sx )*
418 $ aimag( y ).LT.rzero )y = -y
419 END IF
420 t = t - u*cladiv( u, ( x+y ) )
421 END IF
422 END IF
423*
424* Look for two consecutive small subdiagonal elements.
425*
426 DO 60 m = i - 1, l + 1, -1
427*
428* Determine the effect of starting the single-shift QR
429* iteration at row M, and see if this would make H(M,M-1)
430* negligible.
431*
432 h11 = h( m, m )
433 h22 = h( m+1, m+1 )
434 h11s = h11 - t
435 h21 = real( h( m+1, m ) )
436 s = cabs1( h11s ) + abs( h21 )
437 h11s = h11s / s
438 h21 = h21 / s
439 v( 1 ) = h11s
440 v( 2 ) = h21
441 h10 = real( h( m, m-1 ) )
442 IF( abs( h10 )*abs( h21 ).LE.ulp*
443 $ ( cabs1( h11s )*( cabs1( h11 )+cabs1( h22 ) ) ) )
444 $ GO TO 70
445 60 CONTINUE
446 h11 = h( l, l )
447 h22 = h( l+1, l+1 )
448 h11s = h11 - t
449 h21 = real( h( l+1, l ) )
450 s = cabs1( h11s ) + abs( h21 )
451 h11s = h11s / s
452 h21 = h21 / s
453 v( 1 ) = h11s
454 v( 2 ) = h21
455 70 CONTINUE
456*
457* Single-shift QR step
458*
459 DO 120 k = m, i - 1
460*
461* The first iteration of this loop determines a reflection G
462* from the vector V and applies it from left and right to H,
463* thus creating a nonzero bulge below the subdiagonal.
464*
465* Each subsequent iteration determines a reflection G to
466* restore the Hessenberg form in the (K-1)th column, and thus
467* chases the bulge one step toward the bottom of the active
468* submatrix.
469*
470* V(2) is always real before the call to CLARFG, and hence
471* after the call T2 ( = T1*V(2) ) is also real.
472*
473 IF( k.GT.m )
474 $ CALL ccopy( 2, h( k, k-1 ), 1, v, 1 )
475 CALL clarfg( 2, v( 1 ), v( 2 ), 1, t1 )
476 IF( k.GT.m ) THEN
477 h( k, k-1 ) = v( 1 )
478 h( k+1, k-1 ) = zero
479 END IF
480 v2 = v( 2 )
481 t2 = real( t1*v2 )
482*
483* Apply G from the left to transform the rows of the matrix
484* in columns K to I2.
485*
486 DO 80 j = k, i2
487 sum = conjg( t1 )*h( k, j ) + t2*h( k+1, j )
488 h( k, j ) = h( k, j ) - sum
489 h( k+1, j ) = h( k+1, j ) - sum*v2
490 80 CONTINUE
491*
492* Apply G from the right to transform the columns of the
493* matrix in rows I1 to min(K+2,I).
494*
495 DO 90 j = i1, min( k+2, i )
496 sum = t1*h( j, k ) + t2*h( j, k+1 )
497 h( j, k ) = h( j, k ) - sum
498 h( j, k+1 ) = h( j, k+1 ) - sum*conjg( v2 )
499 90 CONTINUE
500*
501 IF( wantz ) THEN
502*
503* Accumulate transformations in the matrix Z
504*
505 DO 100 j = iloz, ihiz
506 sum = t1*z( j, k ) + t2*z( j, k+1 )
507 z( j, k ) = z( j, k ) - sum
508 z( j, k+1 ) = z( j, k+1 ) - sum*conjg( v2 )
509 100 CONTINUE
510 END IF
511*
512 IF( k.EQ.m .AND. m.GT.l ) THEN
513*
514* If the QR step was started at row M > L because two
515* consecutive small subdiagonals were found, then extra
516* scaling must be performed to ensure that H(M,M-1) remains
517* real.
518*
519 temp = one - t1
520 temp = temp / abs( temp )
521 h( m+1, m ) = h( m+1, m )*conjg( temp )
522 IF( m+2.LE.i )
523 $ h( m+2, m+1 ) = h( m+2, m+1 )*temp
524 DO 110 j = m, i
525 IF( j.NE.m+1 ) THEN
526 IF( i2.GT.j )
527 $ CALL cscal( i2-j, temp, h( j, j+1 ), ldh )
528 CALL cscal( j-i1, conjg( temp ), h( i1, j ), 1 )
529 IF( wantz ) THEN
530 CALL cscal( nz, conjg( temp ), z( iloz, j ), 1 )
531 END IF
532 END IF
533 110 CONTINUE
534 END IF
535 120 CONTINUE
536*
537* Ensure that H(I,I-1) is real.
538*
539 temp = h( i, i-1 )
540 IF( aimag( temp ).NE.rzero ) THEN
541 rtemp = abs( temp )
542 h( i, i-1 ) = rtemp
543 temp = temp / rtemp
544 IF( i2.GT.i )
545 $ CALL cscal( i2-i, conjg( temp ), h( i, i+1 ), ldh )
546 CALL cscal( i-i1, temp, h( i1, i ), 1 )
547 IF( wantz ) THEN
548 CALL cscal( nz, temp, z( iloz, i ), 1 )
549 END IF
550 END IF
551*
552 130 CONTINUE
553*
554* Failure to converge in remaining number of iterations
555*
556 info = i
557 RETURN
558*
559 140 CONTINUE
560*
561* H(I,I-1) is negligible: one eigenvalue has converged.
562*
563 w( i ) = h( i, i )
564* reset deflation counter
565 kdefl = 0
566*
567* return to start of the main loop with new value of I.
568*
569 i = l - 1
570 GO TO 30
571*
572 150 CONTINUE
573 RETURN
574*
575* End of CLAHQR
576*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74

◆ clahr2()

subroutine clahr2 ( integer n,
integer k,
integer nb,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( nb ) tau,
complex, dimension( ldt, nb ) t,
integer ldt,
complex, dimension( ldy, nb ) y,
integer ldy )

CLAHR2 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 CLAHR2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
!> matrix A so that elements below the k-th subdiagonal are zero. The
!> reduction is performed by an unitary similarity transformation
!> Q**H * A * Q. The routine returns the matrices V and T which determine
!> Q as a block reflector I - V*T*v**H, and also the matrix Y = A * V * T.
!>
!> This is an auxiliary routine called by CGEHRD.
!>
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 COMPLEX 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 COMPLEX array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is COMPLEX 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 COMPLEX 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**H
!>
!>  where tau is a complex scalar, and v is a complex 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**H) * (A - Y*V**H).
!>
!>  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 CLAHRD
!>  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 CLAHRD routine. (This
!>  subroutine is not backward compatible with LAPACK-3.0's CLAHRD.)
!>
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 clahr2.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 COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ),
191 $ Y( LDY, NB )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 COMPLEX ZERO, ONE
198 parameter( zero = ( 0.0e+0, 0.0e+0 ),
199 $ one = ( 1.0e+0, 0.0e+0 ) )
200* ..
201* .. Local Scalars ..
202 INTEGER I
203 COMPLEX EI
204* ..
205* .. External Subroutines ..
206 EXTERNAL caxpy, ccopy, cgemm, cgemv, clacpy,
207 $ clarfg, cscal, ctrmm, ctrmv, clacgv
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**H
225*
226 CALL clacgv( i-1, a( k+i-1, 1 ), lda )
227 CALL cgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,
228 $ a( k+i-1, 1 ), lda, one, a( k+1, i ), 1 )
229 CALL clacgv( i-1, a( k+i-1, 1 ), lda )
230*
231* Apply I - V * T**H * V**H to this column (call it b) from the
232* left, using the last column of T as workspace
233*
234* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
235* ( V2 ) ( b2 )
236*
237* where V1 is unit lower triangular
238*
239* w := V1**H * b1
240*
241 CALL ccopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
242 CALL ctrmv( 'Lower', 'Conjugate transpose', 'UNIT',
243 $ i-1, a( k+1, 1 ),
244 $ lda, t( 1, nb ), 1 )
245*
246* w := w + V2**H * b2
247*
248 CALL cgemv( 'Conjugate transpose', n-k-i+1, i-1,
249 $ one, a( k+i, 1 ),
250 $ lda, a( k+i, i ), 1, one, t( 1, nb ), 1 )
251*
252* w := T**H * w
253*
254 CALL ctrmv( 'Upper', 'Conjugate transpose', 'NON-UNIT',
255 $ i-1, t, ldt,
256 $ t( 1, nb ), 1 )
257*
258* b2 := b2 - V2*w
259*
260 CALL cgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,
261 $ a( k+i, 1 ),
262 $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 )
263*
264* b1 := b1 - V1*w
265*
266 CALL ctrmv( 'Lower', 'NO TRANSPOSE',
267 $ 'UNIT', i-1,
268 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
269 CALL caxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 )
270*
271 a( k+i-1, i-1 ) = ei
272 END IF
273*
274* Generate the elementary reflector H(I) to annihilate
275* A(K+I+1:N,I)
276*
277 CALL clarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,
278 $ tau( i ) )
279 ei = a( k+i, i )
280 a( k+i, i ) = one
281*
282* Compute Y(K+1:N,I)
283*
284 CALL cgemv( 'NO TRANSPOSE', n-k, n-k-i+1,
285 $ one, a( k+1, i+1 ),
286 $ lda, a( k+i, i ), 1, zero, y( k+1, i ), 1 )
287 CALL cgemv( 'Conjugate transpose', n-k-i+1, i-1,
288 $ one, a( k+i, 1 ), lda,
289 $ a( k+i, i ), 1, zero, t( 1, i ), 1 )
290 CALL cgemv( 'NO TRANSPOSE', n-k, i-1, -one,
291 $ y( k+1, 1 ), ldy,
292 $ t( 1, i ), 1, one, y( k+1, i ), 1 )
293 CALL cscal( n-k, tau( i ), y( k+1, i ), 1 )
294*
295* Compute T(1:I,I)
296*
297 CALL cscal( i-1, -tau( i ), t( 1, i ), 1 )
298 CALL ctrmv( 'Upper', 'No Transpose', 'NON-UNIT',
299 $ i-1, t, ldt,
300 $ t( 1, i ), 1 )
301 t( i, i ) = tau( i )
302*
303 10 CONTINUE
304 a( k+nb, nb ) = ei
305*
306* Compute Y(1:K,1:NB)
307*
308 CALL clacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy )
309 CALL ctrmm( 'RIGHT', 'Lower', 'NO TRANSPOSE',
310 $ 'UNIT', k, nb,
311 $ one, a( k+1, 1 ), lda, y, ldy )
312 IF( n.GT.k+nb )
313 $ CALL cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,
314 $ nb, n-k-nb, one,
315 $ a( 1, 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,
316 $ ldy )
317 CALL ctrmm( 'RIGHT', 'Upper', 'NO TRANSPOSE',
318 $ 'NON-UNIT', k, nb,
319 $ one, t, ldt, y, ldy )
320*
321 RETURN
322*
323* End of CLAHR2
324*
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
ctrmv
subroutine ctrmv(uplo, trans, diag, n, a, lda, x, incx)
CTRMV
Definition ctrmv.f:147
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187

◆ clahrd()

subroutine clahrd ( integer n,
integer k,
integer nb,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( nb ) tau,
complex, dimension( ldt, nb ) t,
integer ldt,
complex, dimension( ldy, nb ) y,
integer ldy )

CLAHRD 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 CLAHRD + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> This routine is deprecated and has been replaced by routine CLAHR2.
!>
!> CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
!> matrix A so that elements below the k-th subdiagonal are zero. The
!> reduction is performed by a unitary similarity transformation
!> Q**H * A * Q. The routine returns the matrices V and T which determine
!> Q as a block reflector I - V*T*V**H, 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 COMPLEX 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 COMPLEX array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is COMPLEX 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 COMPLEX array, dimension (LDY,NB)
!>          The n-by-nb matrix Y.
!>
[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 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**H
!>
!>  where tau is a complex scalar, and v is a complex 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**H) * (A - Y*V**H).
!>
!>  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 clahrd.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 COMPLEX A( LDA, * ), T( LDT, NB ), TAU( NB ),
177 $ Y( LDY, NB )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 COMPLEX ZERO, ONE
184 parameter( zero = ( 0.0e+0, 0.0e+0 ),
185 $ one = ( 1.0e+0, 0.0e+0 ) )
186* ..
187* .. Local Scalars ..
188 INTEGER I
189 COMPLEX EI
190* ..
191* .. External Subroutines ..
192 EXTERNAL caxpy, ccopy, cgemv, clacgv, clarfg, cscal,
193 $ ctrmv
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC min
197* ..
198* .. Executable Statements ..
199*
200* Quick return if possible
201*
202 IF( n.LE.1 )
203 $ RETURN
204*
205 DO 10 i = 1, nb
206 IF( i.GT.1 ) THEN
207*
208* Update A(1:n,i)
209*
210* Compute i-th column of A - Y * V**H
211*
212 CALL clacgv( i-1, a( k+i-1, 1 ), lda )
213 CALL cgemv( 'No transpose', n, i-1, -one, y, ldy,
214 $ a( k+i-1, 1 ), lda, one, a( 1, i ), 1 )
215 CALL clacgv( i-1, a( k+i-1, 1 ), lda )
216*
217* Apply I - V * T**H * V**H to this column (call it b) from the
218* left, using the last column of T as workspace
219*
220* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
221* ( V2 ) ( b2 )
222*
223* where V1 is unit lower triangular
224*
225* w := V1**H * b1
226*
227 CALL ccopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
228 CALL ctrmv( 'Lower', 'Conjugate transpose', 'Unit', i-1,
229 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
230*
231* w := w + V2**H *b2
232*
233 CALL cgemv( 'Conjugate transpose', n-k-i+1, i-1, one,
234 $ a( k+i, 1 ), lda, a( k+i, i ), 1, one,
235 $ t( 1, nb ), 1 )
236*
237* w := T**H *w
238*
239 CALL ctrmv( 'Upper', 'Conjugate transpose', 'Non-unit', i-1,
240 $ t, ldt, t( 1, nb ), 1 )
241*
242* b2 := b2 - V2*w
243*
244 CALL cgemv( 'No transpose', n-k-i+1, i-1, -one, a( k+i, 1 ),
245 $ lda, t( 1, nb ), 1, one, a( k+i, i ), 1 )
246*
247* b1 := b1 - V1*w
248*
249 CALL ctrmv( 'Lower', 'No transpose', 'Unit', i-1,
250 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
251 CALL caxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 )
252*
253 a( k+i-1, i-1 ) = ei
254 END IF
255*
256* Generate the elementary reflector H(i) to annihilate
257* A(k+i+1:n,i)
258*
259 ei = a( k+i, i )
260 CALL clarfg( n-k-i+1, ei, a( min( k+i+1, n ), i ), 1,
261 $ tau( i ) )
262 a( k+i, i ) = one
263*
264* Compute Y(1:n,i)
265*
266 CALL cgemv( 'No transpose', n, n-k-i+1, one, a( 1, i+1 ), lda,
267 $ a( k+i, i ), 1, zero, y( 1, i ), 1 )
268 CALL cgemv( 'Conjugate transpose', n-k-i+1, i-1, one,
269 $ a( k+i, 1 ), lda, a( k+i, i ), 1, zero, t( 1, i ),
270 $ 1 )
271 CALL cgemv( 'No transpose', n, i-1, -one, y, ldy, t( 1, i ), 1,
272 $ one, y( 1, i ), 1 )
273 CALL cscal( n, tau( i ), y( 1, i ), 1 )
274*
275* Compute T(1:i,i)
276*
277 CALL cscal( i-1, -tau( i ), t( 1, i ), 1 )
278 CALL ctrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t, ldt,
279 $ t( 1, i ), 1 )
280 t( i, i ) = tau( i )
281*
282 10 CONTINUE
283 a( k+nb, nb ) = ei
284*
285 RETURN
286*
287* End of CLAHRD
288*

◆ claic1()

subroutine claic1 ( integer job,
integer j,
complex, dimension( j ) x,
real sest,
complex, dimension( j ) w,
complex gamma,
real sestpr,
complex s,
complex c )

CLAIC1 applies one step of incremental condition estimation.

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

Purpose:
!>
!> CLAIC1 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 CLAIC1 computes sestpr, s, c such that
!> the vector
!>                 [ s*x ]
!>          xhat = [  c  ]
!> is an approximate singular vector of
!>                 [ L      0  ]
!>          Lhat = [ w**H 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]**H and sestpr**2 is an eigenpair of the system
!>
!>     diag(sest*sest, 0) + [alpha  gamma] * [ conjg(alpha) ]
!>                                           [ conjg(gamma) ]
!>
!> where  alpha =  x**H*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 COMPLEX array, dimension (J)
!>          The j-vector x.
!>
[in]SEST
!>          SEST is REAL
!>          Estimated singular value of j by j matrix L
!>
[in]W
!>          W is COMPLEX array, dimension (J)
!>          The j-vector w.
!>
[in]GAMMA
!>          GAMMA is COMPLEX
!>          The diagonal element gamma.
!>
[out]SESTPR
!>          SESTPR is REAL
!>          Estimated singular value of (j+1) by (j+1) matrix Lhat.
!>
[out]S
!>          S is COMPLEX
!>          Sine needed in forming xhat.
!>
[out]C
!>          C is COMPLEX
!>          Cosine needed in forming xhat.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file claic1.f.

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

◆ clangt()

real function clangt ( character norm,
integer n,
complex, dimension( * ) dl,
complex, dimension( * ) d,
complex, dimension( * ) du )

CLANGT 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 CLANGT + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLANGT  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> complex tridiagonal matrix A.
!>
Returns
CLANGT 
!>
!>    CLANGT = ( 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 CLANGT as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, CLANGT is
!>          set to zero.
!>
[in]DL
!>          DL is COMPLEX array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX 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 clangt.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 COMPLEX D( * ), DL( * ), DU( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 REAL ONE, ZERO
123 parameter( one = 1.0e+0, zero = 0.0e+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER I
127 REAL ANORM, SCALE, SUM, TEMP
128* ..
129* .. External Functions ..
130 LOGICAL LSAME, SISNAN
131 EXTERNAL lsame, sisnan
132* ..
133* .. External Subroutines ..
134 EXTERNAL classq
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. sisnan( abs( dl( i ) ) ) )
150 $ anorm = abs(dl(i))
151 IF( anorm.LT.abs( d( i ) ) .OR. sisnan( abs( d( i ) ) ) )
152 $ anorm = abs(d(i))
153 IF( anorm.LT.abs( du( i ) ) .OR. sisnan(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. sisnan( 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. sisnan( 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. sisnan( 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. sisnan( 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 classq( n, d, 1, scale, sum )
193 IF( n.GT.1 ) THEN
194 CALL classq( n-1, dl, 1, scale, sum )
195 CALL classq( n-1, du, 1, scale, sum )
196 END IF
197 anorm = scale*sqrt( sum )
198 END IF
199*
200 clangt = anorm
201 RETURN
202*
203* End of CLANGT
204*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
classq
subroutine classq(n, x, incx, scl, sumsq)
CLASSQ updates a sum of squares represented in scaled form.
Definition classq.f90:137
clangt
real function clangt(norm, n, dl, d, du)
CLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clangt.f:106

◆ clanhb()

real function clanhb ( character norm,
character uplo,
integer n,
integer k,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) work )

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

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

Purpose:
!>
!> CLANHB  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 hermitian band matrix A,  with k super-diagonals.
!>
Returns
CLANHB 
!>
!>    CLANHB = ( 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 CLANHB 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
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, CLANHB 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 COMPLEX array, dimension (LDAB,N)
!>          The upper or lower triangle of the hermitian 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 the imaginary parts of the diagonal elements need
!>          not be set and are assumed to be zero.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= K+1.
!>
[out]WORK
!>          WORK is REAL 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 130 of file clanhb.f.

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

◆ clanhp()

real function clanhp ( character norm,
character uplo,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) work )

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

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

Purpose:
!>
!> CLANHP  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> complex hermitian matrix A,  supplied in packed form.
!>
Returns
CLANHP 
!>
!>    CLANHP = ( 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 CLANHP as described
!>          above.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          hermitian 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, CLANHP is
!>          set to zero.
!>
[in]AP
!>          AP is COMPLEX array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the hermitian 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 the  imaginary parts of the diagonal elements need
!>          not be set and are assumed to be zero.
!>
[out]WORK
!>          WORK is REAL 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 116 of file clanhp.f.

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

◆ clanhs()

real function clanhs ( character norm,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) work )

CLANHS 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 CLANHS + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLANHS  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
CLANHS 
!>
!>    CLANHS = ( 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 CLANHS as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, CLANHS is
!>          set to zero.
!>
[in]A
!>          A is COMPLEX 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 REAL 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 108 of file clanhs.f.

109*
110* -- LAPACK auxiliary routine --
111* -- LAPACK is a software package provided by Univ. of Tennessee, --
112* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
113*
114* .. Scalar Arguments ..
115 CHARACTER NORM
116 INTEGER LDA, N
117* ..
118* .. Array Arguments ..
119 REAL WORK( * )
120 COMPLEX A( LDA, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 REAL ONE, ZERO
127 parameter( one = 1.0e+0, zero = 0.0e+0 )
128* ..
129* .. Local Scalars ..
130 INTEGER I, J
131 REAL SCALE, SUM, VALUE
132* ..
133* .. External Functions ..
134 LOGICAL LSAME, SISNAN
135 EXTERNAL lsame, sisnan
136* ..
137* .. External Subroutines ..
138 EXTERNAL classq
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC abs, min, sqrt
142* ..
143* .. Executable Statements ..
144*
145 IF( n.EQ.0 ) THEN
146 VALUE = zero
147 ELSE IF( lsame( norm, 'M' ) ) THEN
148*
149* Find max(abs(A(i,j))).
150*
151 VALUE = zero
152 DO 20 j = 1, n
153 DO 10 i = 1, min( n, j+1 )
154 sum = abs( a( i, j ) )
155 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
156 10 CONTINUE
157 20 CONTINUE
158 ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm.EQ.'1' ) ) THEN
159*
160* Find norm1(A).
161*
162 VALUE = zero
163 DO 40 j = 1, n
164 sum = zero
165 DO 30 i = 1, min( n, j+1 )
166 sum = sum + abs( a( i, j ) )
167 30 CONTINUE
168 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
169 40 CONTINUE
170 ELSE IF( lsame( norm, 'I' ) ) THEN
171*
172* Find normI(A).
173*
174 DO 50 i = 1, n
175 work( i ) = zero
176 50 CONTINUE
177 DO 70 j = 1, n
178 DO 60 i = 1, min( n, j+1 )
179 work( i ) = work( i ) + abs( a( i, j ) )
180 60 CONTINUE
181 70 CONTINUE
182 VALUE = zero
183 DO 80 i = 1, n
184 sum = work( i )
185 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
186 80 CONTINUE
187 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
188*
189* Find normF(A).
190*
191 scale = zero
192 sum = one
193 DO 90 j = 1, n
194 CALL classq( min( n, j+1 ), a( 1, j ), 1, scale, sum )
195 90 CONTINUE
196 VALUE = scale*sqrt( sum )
197 END IF
198*
199 clanhs = VALUE
200 RETURN
201*
202* End of CLANHS
203*
clanhs
real function clanhs(norm, n, a, lda, work)
CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clanhs.f:109

◆ clanht()

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

CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian tridiagonal matrix.

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

Purpose:
!>
!> CLANHT  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> complex Hermitian tridiagonal matrix A.
!>
Returns
CLANHT 
!>
!>    CLANHT = ( 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 CLANHT as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, CLANHT is
!>          set to zero.
!>
[in]D
!>          D is REAL array, dimension (N)
!>          The diagonal elements of A.
!>
[in]E
!>          E is COMPLEX array, dimension (N-1)
!>          The (n-1) sub-diagonal or super-diagonal elements of A.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 100 of file clanht.f.

101*
102* -- LAPACK auxiliary routine --
103* -- LAPACK is a software package provided by Univ. of Tennessee, --
104* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
105*
106* .. Scalar Arguments ..
107 CHARACTER NORM
108 INTEGER N
109* ..
110* .. Array Arguments ..
111 REAL D( * )
112 COMPLEX E( * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 REAL ONE, ZERO
119 parameter( one = 1.0e+0, zero = 0.0e+0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I
123 REAL ANORM, SCALE, SUM
124* ..
125* .. External Functions ..
126 LOGICAL LSAME, SISNAN
127 EXTERNAL lsame, sisnan
128* ..
129* .. External Subroutines ..
130 EXTERNAL classq, slassq
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC abs, sqrt
134* ..
135* .. Executable Statements ..
136*
137 IF( n.LE.0 ) THEN
138 anorm = zero
139 ELSE IF( lsame( norm, 'M' ) ) THEN
140*
141* Find max(abs(A(i,j))).
142*
143 anorm = abs( d( n ) )
144 DO 10 i = 1, n - 1
145 sum = abs( d( i ) )
146 IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
147 sum = abs( e( i ) )
148 IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
149 10 CONTINUE
150 ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' .OR.
151 $ lsame( norm, 'I' ) ) THEN
152*
153* Find norm1(A).
154*
155 IF( n.EQ.1 ) THEN
156 anorm = abs( d( 1 ) )
157 ELSE
158 anorm = abs( d( 1 ) )+abs( e( 1 ) )
159 sum = abs( e( n-1 ) )+abs( d( n ) )
160 IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
161 DO 20 i = 2, n - 1
162 sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) )
163 IF( anorm .LT. sum .OR. sisnan( sum ) ) anorm = sum
164 20 CONTINUE
165 END IF
166 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
167*
168* Find normF(A).
169*
170 scale = zero
171 sum = one
172 IF( n.GT.1 ) THEN
173 CALL classq( n-1, e, 1, scale, sum )
174 sum = 2*sum
175 END IF
176 CALL slassq( n, d, 1, scale, sum )
177 anorm = scale*sqrt( sum )
178 END IF
179*
180 clanht = anorm
181 RETURN
182*
183* End of CLANHT
184*
slassq
subroutine slassq(n, x, incx, scl, sumsq)
SLASSQ updates a sum of squares represented in scaled form.
Definition slassq.f90:137
clanht
real function clanht(norm, n, d, e)
CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanht.f:101

◆ clansb()

real function clansb ( character norm,
character uplo,
integer n,
integer k,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) work )

CLANSB 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 CLANSB + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLANSB  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
CLANSB 
!>
!>    CLANSB = ( 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 CLANSB 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, CLANSB 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 COMPLEX 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 REAL 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 128 of file clansb.f.

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

◆ clansp()

real function clansp ( character norm,
character uplo,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) work )

CLANSP 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 CLANSP + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLANSP  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> complex symmetric matrix A,  supplied in packed form.
!>
Returns
CLANSP 
!>
!>    CLANSP = ( 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 CLANSP 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, CLANSP is
!>          set to zero.
!>
[in]AP
!>          AP is COMPLEX 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 REAL 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 114 of file clansp.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 CHARACTER NORM, UPLO
122 INTEGER N
123* ..
124* .. Array Arguments ..
125 REAL WORK( * )
126 COMPLEX AP( * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL ONE, ZERO
133 parameter( one = 1.0e+0, zero = 0.0e+0 )
134* ..
135* .. Local Scalars ..
136 INTEGER I, J, K
137 REAL ABSA, SCALE, SUM, VALUE
138* ..
139* .. External Functions ..
140 LOGICAL LSAME, SISNAN
141 EXTERNAL lsame, sisnan
142* ..
143* .. External Subroutines ..
144 EXTERNAL classq
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, aimag, real, sqrt
148* ..
149* .. Executable Statements ..
150*
151 IF( n.EQ.0 ) THEN
152 VALUE = zero
153 ELSE IF( lsame( norm, 'M' ) ) THEN
154*
155* Find max(abs(A(i,j))).
156*
157 VALUE = zero
158 IF( lsame( uplo, 'U' ) ) THEN
159 k = 1
160 DO 20 j = 1, n
161 DO 10 i = k, k + j - 1
162 sum = abs( ap( i ) )
163 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
164 10 CONTINUE
165 k = k + j
166 20 CONTINUE
167 ELSE
168 k = 1
169 DO 40 j = 1, n
170 DO 30 i = k, k + n - j
171 sum = abs( ap( i ) )
172 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
173 30 CONTINUE
174 k = k + n - j + 1
175 40 CONTINUE
176 END IF
177 ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR.
178 $ ( norm.EQ.'1' ) ) THEN
179*
180* Find normI(A) ( = norm1(A), since A is symmetric).
181*
182 VALUE = zero
183 k = 1
184 IF( lsame( uplo, 'U' ) ) THEN
185 DO 60 j = 1, n
186 sum = zero
187 DO 50 i = 1, j - 1
188 absa = abs( ap( k ) )
189 sum = sum + absa
190 work( i ) = work( i ) + absa
191 k = k + 1
192 50 CONTINUE
193 work( j ) = sum + abs( ap( k ) )
194 k = k + 1
195 60 CONTINUE
196 DO 70 i = 1, n
197 sum = work( i )
198 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
199 70 CONTINUE
200 ELSE
201 DO 80 i = 1, n
202 work( i ) = zero
203 80 CONTINUE
204 DO 100 j = 1, n
205 sum = work( j ) + abs( ap( k ) )
206 k = k + 1
207 DO 90 i = j + 1, n
208 absa = abs( ap( k ) )
209 sum = sum + absa
210 work( i ) = work( i ) + absa
211 k = k + 1
212 90 CONTINUE
213 IF( VALUE .LT. sum .OR. sisnan( sum ) ) VALUE = sum
214 100 CONTINUE
215 END IF
216 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
217*
218* Find normF(A).
219*
220 scale = zero
221 sum = one
222 k = 2
223 IF( lsame( uplo, 'U' ) ) THEN
224 DO 110 j = 2, n
225 CALL classq( j-1, ap( k ), 1, scale, sum )
226 k = k + j
227 110 CONTINUE
228 ELSE
229 DO 120 j = 1, n - 1
230 CALL classq( n-j, ap( k ), 1, scale, sum )
231 k = k + n - j + 1
232 120 CONTINUE
233 END IF
234 sum = 2*sum
235 k = 1
236 DO 130 i = 1, n
237 IF( real( ap( k ) ).NE.zero ) THEN
238 absa = abs( real( ap( k ) ) )
239 IF( scale.LT.absa ) THEN
240 sum = one + sum*( scale / absa )**2
241 scale = absa
242 ELSE
243 sum = sum + ( absa / scale )**2
244 END IF
245 END IF
246 IF( aimag( ap( k ) ).NE.zero ) THEN
247 absa = abs( aimag( ap( k ) ) )
248 IF( scale.LT.absa ) THEN
249 sum = one + sum*( scale / absa )**2
250 scale = absa
251 ELSE
252 sum = sum + ( absa / scale )**2
253 END IF
254 END IF
255 IF( lsame( uplo, 'U' ) ) THEN
256 k = k + i + 1
257 ELSE
258 k = k + n - i + 1
259 END IF
260 130 CONTINUE
261 VALUE = scale*sqrt( sum )
262 END IF
263*
264 clansp = VALUE
265 RETURN
266*
267* End of CLANSP
268*
clansp
real function clansp(norm, uplo, n, ap, work)
CLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clansp.f:115

◆ clantb()

real function clantb ( character norm,
character uplo,
character diag,
integer n,
integer k,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) work )

CLANTB 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 CLANTB + dependencies [TGZ] [ZIP] [TXT]

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

◆ clantp()

real function clantp ( character norm,
character uplo,
character diag,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) work )

CLANTP 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 CLANTP + dependencies [TGZ] [ZIP] [TXT]

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

◆ clantr()

real function clantr ( character norm,
character uplo,
character diag,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) work )

CLANTR 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 CLANTR + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!> CLANTR  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
CLANTR 
!>
!>    CLANTR = ( 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 CLANTR 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, CLANTR 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, CLANTR is set to zero.
!>
[in]A
!>          A is COMPLEX 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 REAL 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 140 of file clantr.f.

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

◆ clapll()

subroutine clapll ( integer n,
complex, dimension( * ) x,
integer incx,
complex, dimension( * ) y,
integer incy,
real ssmin )

CLAPLL measures the linear dependence of two vectors.

Download CLAPLL + 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 COMPLEX 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 COMPLEX 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 REAL
!>          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 99 of file clapll.f.

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

◆ clapmr()

subroutine clapmr ( logical forwrd,
integer m,
integer n,
complex, dimension( ldx, * ) x,
integer ldx,
integer, dimension( * ) k )

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

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

Purpose:
!>
!> CLAPMR 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 COMPLEX 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 clapmr.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 COMPLEX X( LDX, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, IN, J, JJ
122 COMPLEX 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 CLAPMR
199*

◆ clapmt()

subroutine clapmt ( logical forwrd,
integer m,
integer n,
complex, dimension( ldx, * ) x,
integer ldx,
integer, dimension( * ) k )

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

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

Purpose:
!>
!> CLAPMT 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 COMPLEX 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 clapmt.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 COMPLEX X( LDX, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, II, J, IN
122 COMPLEX 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 60 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 60 CONTINUE
164*
165 ELSE
166*
167* Backward permutation
168*
169 DO 110 i = 1, n
170*
171 IF( k( i ).GT.0 )
172 $ GO TO 100
173*
174 k( i ) = -k( i )
175 j = k( i )
176 80 CONTINUE
177 IF( j.EQ.i )
178 $ GO TO 100
179*
180 DO 90 ii = 1, m
181 temp = x( ii, i )
182 x( ii, i ) = x( ii, j )
183 x( ii, j ) = temp
184 90 CONTINUE
185*
186 k( j ) = -k( j )
187 j = k( j )
188 GO TO 80
189*
190 100 CONTINUE
191
192 110 CONTINUE
193*
194 END IF
195*
196 RETURN
197*
198* End of CLAPMT
199*

◆ claqhb()

subroutine claqhb ( character uplo,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) s,
real scond,
real amax,
character equed )

CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.

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

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

◆ claqhp()

subroutine claqhp ( character uplo,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) s,
real scond,
real amax,
character equed )

CLAQHP scales a Hermitian matrix stored in packed form.

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

Purpose:
!>
!> CLAQHP equilibrates a Hermitian 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
!>          Hermitian 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 COMPLEX array, dimension (N*(N+1)/2)
!>          On entry, the upper or lower triangle of the Hermitian 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 REAL array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is REAL
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is REAL
!>          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 125 of file claqhp.f.

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

◆ claqp2()

subroutine claqp2 ( integer m,
integer n,
integer offset,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex, dimension( * ) tau,
real, dimension( * ) vn1,
real, dimension( * ) vn2,
complex, dimension( * ) work )

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

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

Purpose:
!>
!> CLAQP2 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 COMPLEX 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 COMPLEX array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is REAL array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is REAL array, dimension (N)
!>          The vector with the exact column norms.
!>
[out]WORK
!>          WORK is COMPLEX 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 claqp2.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 REAL VN1( * ), VN2( * )
160 COMPLEX A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ZERO, ONE
167 COMPLEX CONE
168 parameter( zero = 0.0e+0, one = 1.0e+0,
169 $ cone = ( 1.0e+0, 0.0e+0 ) )
170* ..
171* .. Local Scalars ..
172 INTEGER I, ITEMP, J, MN, OFFPI, PVT
173 REAL TEMP, TEMP2, TOL3Z
174 COMPLEX AII
175* ..
176* .. External Subroutines ..
177 EXTERNAL clarf, clarfg, cswap
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC abs, conjg, max, min, sqrt
181* ..
182* .. External Functions ..
183 INTEGER ISAMAX
184 REAL SCNRM2, SLAMCH
185 EXTERNAL isamax, scnrm2, slamch
186* ..
187* .. Executable Statements ..
188*
189 mn = min( m-offset, n )
190 tol3z = sqrt(slamch('Epsilon'))
191*
192* Compute factorization.
193*
194 DO 20 i = 1, mn
195*
196 offpi = offset + i
197*
198* Determine ith pivot column and swap if necessary.
199*
200 pvt = ( i-1 ) + isamax( n-i+1, vn1( i ), 1 )
201*
202 IF( pvt.NE.i ) THEN
203 CALL cswap( m, a( 1, pvt ), 1, a( 1, i ), 1 )
204 itemp = jpvt( pvt )
205 jpvt( pvt ) = jpvt( i )
206 jpvt( i ) = itemp
207 vn1( pvt ) = vn1( i )
208 vn2( pvt ) = vn2( i )
209 END IF
210*
211* Generate elementary reflector H(i).
212*
213 IF( offpi.LT.m ) THEN
214 CALL clarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1,
215 $ tau( i ) )
216 ELSE
217 CALL clarfg( 1, a( m, i ), a( m, i ), 1, tau( i ) )
218 END IF
219*
220 IF( i.LT.n ) THEN
221*
222* Apply H(i)**H to A(offset+i:m,i+1:n) from the left.
223*
224 aii = a( offpi, i )
225 a( offpi, i ) = cone
226 CALL clarf( 'Left', m-offpi+1, n-i, a( offpi, i ), 1,
227 $ conjg( tau( i ) ), a( offpi, i+1 ), lda,
228 $ work( 1 ) )
229 a( offpi, i ) = aii
230 END IF
231*
232* Update partial column norms.
233*
234 DO 10 j = i + 1, n
235 IF( vn1( j ).NE.zero ) THEN
236*
237* NOTE: The following 4 lines follow from the analysis in
238* Lapack Working Note 176.
239*
240 temp = one - ( abs( a( offpi, j ) ) / vn1( j ) )**2
241 temp = max( temp, zero )
242 temp2 = temp*( vn1( j ) / vn2( j ) )**2
243 IF( temp2 .LE. tol3z ) THEN
244 IF( offpi.LT.m ) THEN
245 vn1( j ) = scnrm2( m-offpi, a( offpi+1, j ), 1 )
246 vn2( j ) = vn1( j )
247 ELSE
248 vn1( j ) = zero
249 vn2( j ) = zero
250 END IF
251 ELSE
252 vn1( j ) = vn1( j )*sqrt( temp )
253 END IF
254 END IF
255 10 CONTINUE
256*
257 20 CONTINUE
258*
259 RETURN
260*
261* End of CLAQP2
262*
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
clarf
subroutine clarf(side, m, n, v, incv, tau, c, ldc, work)
CLARF applies an elementary reflector to a general rectangular matrix.
Definition clarf.f:128
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81

◆ claqps()

subroutine claqps ( integer m,
integer n,
integer offset,
integer nb,
integer kb,
complex, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) jpvt,
complex, dimension( * ) tau,
real, dimension( * ) vn1,
real, dimension( * ) vn2,
complex, dimension( * ) auxv,
complex, dimension( ldf, * ) f,
integer ldf )

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

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

Purpose:
!>
!> CLAQPS computes a step of QR factorization with column pivoting
!> of a complex 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 COMPLEX 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 COMPLEX array, dimension (KB)
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is REAL array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is REAL array, dimension (N)
!>          The vector with the exact column norms.
!>
[in,out]AUXV
!>          AUXV is COMPLEX array, dimension (NB)
!>          Auxiliary vector.
!>
[in,out]F
!>          F is COMPLEX array, dimension (LDF,NB)
!>          Matrix  F**H = L * Y**H * 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 176 of file claqps.f.

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

◆ claqr0()

subroutine claqr0 ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( * ) w,
integer iloz,
integer ihiz,
complex, dimension( ldz, * ) z,
integer ldz,
complex, dimension( * ) work,
integer lwork,
integer info )

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

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

Purpose:
!>
!>    CLAQR0 computes the eigenvalues of a Hessenberg matrix H
!>    and, optionally, the matrices T and Z from the Schur decomposition
!>    H = Z T Z**H, where T is an upper triangular matrix (the
!>    Schur form), and Z is the unitary matrix of Schur vectors.
!>
!>    Optionally Z may be postmultiplied into an input unitary
!>    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 unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
!>
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 CGEBAL, and then passed to CGEHRD when the
!>           matrix output by CGEBAL 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 COMPLEX 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 triangular matrix T from the Schur
!>           decomposition (the Schur form). If INFO = 0 and WANT 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]W
!>          W is COMPLEX array, dimension (N)
!>           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
!>           in W(ILO:IHI). 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 W(i) = H(i,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 COMPLEX 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 COMPLEX 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 CLAQR0 does a workspace query.
!>           In this case, CLAQR0 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, CLAQR0 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 unitary 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 unitary 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 238 of file claqr0.f.

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

◆ claqr1()

subroutine claqr1 ( integer n,
complex, dimension( ldh, * ) h,
integer ldh,
complex s1,
complex s2,
complex, dimension( * ) v )

CLAQR1 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 CLAQR1 + dependencies [TGZ] [ZIP] [TXT]

Purpose:
!>
!>      Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a
!>      scalar multiple of the first column of the product
!>
!>      (*)  K = (H - s1*I)*(H - s2*I)
!>
!>      scaling to avoid overflows and most underflows.
!>
!>      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 COMPLEX 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]S1
!>          S1 is COMPLEX
!>
[in]S2
!>          S2 is COMPLEX
!>
!>          S1 and S2 are the shifts defining K in (*) above.
!>
[out]V
!>          V is COMPLEX 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 106 of file claqr1.f.

107*
108* -- LAPACK auxiliary routine --
109* -- LAPACK is a software package provided by Univ. of Tennessee, --
110* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
111*
112* .. Scalar Arguments ..
113 COMPLEX S1, S2
114 INTEGER LDH, N
115* ..
116* .. Array Arguments ..
117 COMPLEX H( LDH, * ), V( * )
118* ..
119*
120* ================================================================
121*
122* .. Parameters ..
123 COMPLEX ZERO
124 parameter( zero = ( 0.0e0, 0.0e0 ) )
125 REAL RZERO
126 parameter( rzero = 0.0e0 )
127* ..
128* .. Local Scalars ..
129 COMPLEX CDUM, H21S, H31S
130 REAL S
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC abs, aimag, real
134* ..
135* .. Statement Functions ..
136 REAL CABS1
137* ..
138* .. Statement Function definitions ..
139 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
140* ..
141* .. Executable Statements ..
142*
143* Quick return if possible
144*
145 IF( n.NE.2 .AND. n.NE.3 ) THEN
146 RETURN
147 END IF
148*
149 IF( n.EQ.2 ) THEN
150 s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) )
151 IF( s.EQ.rzero ) THEN
152 v( 1 ) = zero
153 v( 2 ) = zero
154 ELSE
155 h21s = h( 2, 1 ) / s
156 v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )*
157 $ ( ( h( 1, 1 )-s2 ) / s )
158 v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 )
159 END IF
160 ELSE
161 s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) +
162 $ cabs1( h( 3, 1 ) )
163 IF( s.EQ.zero ) THEN
164 v( 1 ) = zero
165 v( 2 ) = zero
166 v( 3 ) = zero
167 ELSE
168 h21s = h( 2, 1 ) / s
169 h31s = h( 3, 1 ) / s
170 v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) +
171 $ h( 1, 2 )*h21s + h( 1, 3 )*h31s
172 v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s
173 v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 )
174 END IF
175 END IF

◆ claqr2()

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

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

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

Purpose:
!>
!>    CLAQR2 is identical to CLAQR3 except that it avoids
!>    recursion by calling CLAHQR instead of CLAQR4.
!>
!>    Aggressive early deflation:
!>
!>    This subroutine accepts as input an upper Hessenberg matrix
!>    H and performs an unitary 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 unitary 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 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 unitary matrix Z is updated so
!>          so that the unitary 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 unitary 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 COMPLEX 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 a unitary
!>          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 COMPLEX array, dimension (LDZ,N)
!>          IF WANTZ is .TRUE., then on output, the unitary
!>          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]SH
!>          SH is COMPLEX array, dimension (KBOT)
!>          On output, approximate eigenvalues that may
!>          be used for shifts are stored in SH(KBOT-ND-NS+1)
!>          through SR(KBOT-ND).  Converged eigenvalues are
!>          stored in SH(KBOT-ND+1) through SH(KBOT).
!>
[out]V
!>          V is COMPLEX 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 COMPLEX 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 COMPLEX 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 COMPLEX 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; CLAQR2
!>          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 266 of file claqr2.f.

269*
270* -- LAPACK auxiliary routine --
271* -- LAPACK is a software package provided by Univ. of Tennessee, --
272* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
273*
274* .. Scalar Arguments ..
275 INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
276 $ LDZ, LWORK, N, ND, NH, NS, NV, NW
277 LOGICAL WANTT, WANTZ
278* ..
279* .. Array Arguments ..
280 COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
281 $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
282* ..
283*
284* ================================================================
285*
286* .. Parameters ..
287 COMPLEX ZERO, ONE
288 parameter( zero = ( 0.0e0, 0.0e0 ),
289 $ one = ( 1.0e0, 0.0e0 ) )
290 REAL RZERO, RONE
291 parameter( rzero = 0.0e0, rone = 1.0e0 )
292* ..
293* .. Local Scalars ..
294 COMPLEX BETA, CDUM, S, TAU
295 REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP
296 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
297 $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
298* ..
299* .. External Functions ..
300 REAL SLAMCH
301 EXTERNAL slamch
302* ..
303* .. External Subroutines ..
304 EXTERNAL ccopy, cgehrd, cgemm, clacpy, clahqr, clarf,
305 $ clarfg, claset, ctrexc, cunmhr, slabad
306* ..
307* .. Intrinsic Functions ..
308 INTRINSIC abs, aimag, cmplx, conjg, int, max, min, real
309* ..
310* .. Statement Functions ..
311 REAL CABS1
312* ..
313* .. Statement Function definitions ..
314 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
315* ..
316* .. Executable Statements ..
317*
318* ==== Estimate optimal workspace. ====
319*
320 jw = min( nw, kbot-ktop+1 )
321 IF( jw.LE.2 ) THEN
322 lwkopt = 1
323 ELSE
324*
325* ==== Workspace query call to CGEHRD ====
326*
327 CALL cgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
328 lwk1 = int( work( 1 ) )
329*
330* ==== Workspace query call to CUNMHR ====
331*
332 CALL cunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
333 $ work, -1, info )
334 lwk2 = int( work( 1 ) )
335*
336* ==== Optimal workspace ====
337*
338 lwkopt = jw + max( lwk1, lwk2 )
339 END IF
340*
341* ==== Quick return in case of workspace query. ====
342*
343 IF( lwork.EQ.-1 ) THEN
344 work( 1 ) = cmplx( lwkopt, 0 )
345 RETURN
346 END IF
347*
348* ==== Nothing to do ...
349* ... for an empty active block ... ====
350 ns = 0
351 nd = 0
352 work( 1 ) = one
353 IF( ktop.GT.kbot )
354 $ RETURN
355* ... nor for an empty deflation window. ====
356 IF( nw.LT.1 )
357 $ RETURN
358*
359* ==== Machine constants ====
360*
361 safmin = slamch( 'SAFE MINIMUM' )
362 safmax = rone / safmin
363 CALL slabad( safmin, safmax )
364 ulp = slamch( 'PRECISION' )
365 smlnum = safmin*( real( n ) / ulp )
366*
367* ==== Setup deflation window ====
368*
369 jw = min( nw, kbot-ktop+1 )
370 kwtop = kbot - jw + 1
371 IF( kwtop.EQ.ktop ) THEN
372 s = zero
373 ELSE
374 s = h( kwtop, kwtop-1 )
375 END IF
376*
377 IF( kbot.EQ.kwtop ) THEN
378*
379* ==== 1-by-1 deflation window: not much to do ====
380*
381 sh( kwtop ) = h( kwtop, kwtop )
382 ns = 1
383 nd = 0
384 IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop,
385 $ kwtop ) ) ) ) THEN
386 ns = 0
387 nd = 1
388 IF( kwtop.GT.ktop )
389 $ h( kwtop, kwtop-1 ) = zero
390 END IF
391 work( 1 ) = one
392 RETURN
393 END IF
394*
395* ==== Convert to spike-triangular form. (In case of a
396* . rare QR failure, this routine continues to do
397* . aggressive early deflation using that part of
398* . the deflation window that converged using INFQR
399* . here and there to keep track.) ====
400*
401 CALL clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
402 CALL ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
403*
404 CALL claset( 'A', jw, jw, zero, one, v, ldv )
405 CALL clahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
406 $ jw, v, ldv, infqr )
407*
408* ==== Deflation detection loop ====
409*
410 ns = jw
411 ilst = infqr + 1
412 DO 10 knt = infqr + 1, jw
413*
414* ==== Small spike tip deflation test ====
415*
416 foo = cabs1( t( ns, ns ) )
417 IF( foo.EQ.rzero )
418 $ foo = cabs1( s )
419 IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) )
420 $ THEN
421*
422* ==== One more converged eigenvalue ====
423*
424 ns = ns - 1
425 ELSE
426*
427* ==== One undeflatable eigenvalue. Move it up out of the
428* . way. (CTREXC can not fail in this case.) ====
429*
430 ifst = ns
431 CALL ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
432 ilst = ilst + 1
433 END IF
434 10 CONTINUE
435*
436* ==== Return to Hessenberg form ====
437*
438 IF( ns.EQ.0 )
439 $ s = zero
440*
441 IF( ns.LT.jw ) THEN
442*
443* ==== sorting the diagonal of T improves accuracy for
444* . graded matrices. ====
445*
446 DO 30 i = infqr + 1, ns
447 ifst = i
448 DO 20 j = i + 1, ns
449 IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) )
450 $ ifst = j
451 20 CONTINUE
452 ilst = i
453 IF( ifst.NE.ilst )
454 $ CALL ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
455 30 CONTINUE
456 END IF
457*
458* ==== Restore shift/eigenvalue array from T ====
459*
460 DO 40 i = infqr + 1, jw
461 sh( kwtop+i-1 ) = t( i, i )
462 40 CONTINUE
463*
464*
465 IF( ns.LT.jw .OR. s.EQ.zero ) THEN
466 IF( ns.GT.1 .AND. s.NE.zero ) THEN
467*
468* ==== Reflect spike back into lower triangle ====
469*
470 CALL ccopy( ns, v, ldv, work, 1 )
471 DO 50 i = 1, ns
472 work( i ) = conjg( work( i ) )
473 50 CONTINUE
474 beta = work( 1 )
475 CALL clarfg( ns, beta, work( 2 ), 1, tau )
476 work( 1 ) = one
477*
478 CALL claset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
479*
480 CALL clarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,
481 $ work( jw+1 ) )
482 CALL clarf( 'R', ns, ns, work, 1, tau, t, ldt,
483 $ work( jw+1 ) )
484 CALL clarf( 'R', jw, ns, work, 1, tau, v, ldv,
485 $ work( jw+1 ) )
486*
487 CALL cgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
488 $ lwork-jw, info )
489 END IF
490*
491* ==== Copy updated reduced window into place ====
492*
493 IF( kwtop.GT.1 )
494 $ h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) )
495 CALL clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
496 CALL ccopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
497 $ ldh+1 )
498*
499* ==== Accumulate orthogonal matrix in order update
500* . H and Z, if requested. ====
501*
502 IF( ns.GT.1 .AND. s.NE.zero )
503 $ CALL cunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
504 $ work( jw+1 ), lwork-jw, info )
505*
506* ==== Update vertical slab in H ====
507*
508 IF( wantt ) THEN
509 ltop = 1
510 ELSE
511 ltop = ktop
512 END IF
513 DO 60 krow = ltop, kwtop - 1, nv
514 kln = min( nv, kwtop-krow )
515 CALL cgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
516 $ ldh, v, ldv, zero, wv, ldwv )
517 CALL clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
518 60 CONTINUE
519*
520* ==== Update horizontal slab in H ====
521*
522 IF( wantt ) THEN
523 DO 70 kcol = kbot + 1, n, nh
524 kln = min( nh, n-kcol+1 )
525 CALL cgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
526 $ h( kwtop, kcol ), ldh, zero, t, ldt )
527 CALL clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
528 $ ldh )
529 70 CONTINUE
530 END IF
531*
532* ==== Update vertical slab in Z ====
533*
534 IF( wantz ) THEN
535 DO 80 krow = iloz, ihiz, nv
536 kln = min( nv, ihiz-krow+1 )
537 CALL cgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
538 $ ldz, v, ldv, zero, wv, ldwv )
539 CALL clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
540 $ ldz )
541 80 CONTINUE
542 END IF
543 END IF
544*
545* ==== Return the number of deflations ... ====
546*
547 nd = jw - ns
548*
549* ==== ... and the number of shifts. (Subtracting
550* . INFQR from the spike length takes care
551* . of the case of a rare QR failure while
552* . calculating eigenvalues of the deflation
553* . window.) ====
554*
555 ns = ns - infqr
556*
557* ==== Return optimal workspace. ====
558*
559 work( 1 ) = cmplx( lwkopt, 0 )
560*
561* ==== End of CLAQR2 ====
562*
cgehrd
subroutine cgehrd(n, ilo, ihi, a, lda, tau, work, lwork, info)
CGEHRD
Definition cgehrd.f:167
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:106
ctrexc
subroutine ctrexc(compq, n, t, ldt, q, ldq, ifst, ilst, info)
CTREXC
Definition ctrexc.f:126
cunmhr
subroutine cunmhr(side, trans, m, n, ilo, ihi, a, lda, tau, c, ldc, work, lwork, info)
CUNMHR
Definition cunmhr.f:179

◆ claqr3()

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

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

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

Purpose:
!>
!>    Aggressive early deflation:
!>
!>    CLAQR3 accepts as input an upper Hessenberg matrix
!>    H and performs an unitary 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 unitary 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 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 unitary matrix Z is updated so
!>          so that the unitary 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 unitary 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 COMPLEX 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 a unitary
!>          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 COMPLEX array, dimension (LDZ,N)
!>          IF WANTZ is .TRUE., then on output, the unitary
!>          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]SH
!>          SH is COMPLEX array, dimension (KBOT)
!>          On output, approximate eigenvalues that may
!>          be used for shifts are stored in SH(KBOT-ND-NS+1)
!>          through SR(KBOT-ND).  Converged eigenvalues are
!>          stored in SH(KBOT-ND+1) through SH(KBOT).
!>
[out]V
!>          V is COMPLEX 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 COMPLEX 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 COMPLEX 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 COMPLEX 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; CLAQR3
!>          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 263 of file claqr3.f.

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, KBOT, KTOP, LDH, LDT, LDV, LDWV,
273 $ LDZ, LWORK, N, ND, NH, NS, NV, NW
274 LOGICAL WANTT, WANTZ
275* ..
276* .. Array Arguments ..
277 COMPLEX H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
278 $ WORK( * ), WV( LDWV, * ), Z( LDZ, * )
279* ..
280*
281* ================================================================
282*
283* .. Parameters ..
284 COMPLEX ZERO, ONE
285 parameter( zero = ( 0.0e0, 0.0e0 ),
286 $ one = ( 1.0e0, 0.0e0 ) )
287 REAL RZERO, RONE
288 parameter( rzero = 0.0e0, rone = 1.0e0 )
289* ..
290* .. Local Scalars ..
291 COMPLEX BETA, CDUM, S, TAU
292 REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP
293 INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
294 $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
295 $ LWKOPT, NMIN
296* ..
297* .. External Functions ..
298 REAL SLAMCH
299 INTEGER ILAENV
300 EXTERNAL slamch, ilaenv
301* ..
302* .. External Subroutines ..
303 EXTERNAL ccopy, cgehrd, cgemm, clacpy, clahqr, claqr4,
304 $ clarf, clarfg, claset, ctrexc, cunmhr, slabad
305* ..
306* .. Intrinsic Functions ..
307 INTRINSIC abs, aimag, cmplx, conjg, int, max, min, real
308* ..
309* .. Statement Functions ..
310 REAL CABS1
311* ..
312* .. Statement Function definitions ..
313 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
314* ..
315* .. Executable Statements ..
316*
317* ==== Estimate optimal workspace. ====
318*
319 jw = min( nw, kbot-ktop+1 )
320 IF( jw.LE.2 ) THEN
321 lwkopt = 1
322 ELSE
323*
324* ==== Workspace query call to CGEHRD ====
325*
326 CALL cgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info )
327 lwk1 = int( work( 1 ) )
328*
329* ==== Workspace query call to CUNMHR ====
330*
331 CALL cunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,
332 $ work, -1, info )
333 lwk2 = int( work( 1 ) )
334*
335* ==== Workspace query call to CLAQR4 ====
336*
337 CALL claqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,
338 $ ldv, work, -1, infqr )
339 lwk3 = int( work( 1 ) )
340*
341* ==== Optimal workspace ====
342*
343 lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 )
344 END IF
345*
346* ==== Quick return in case of workspace query. ====
347*
348 IF( lwork.EQ.-1 ) THEN
349 work( 1 ) = cmplx( lwkopt, 0 )
350 RETURN
351 END IF
352*
353* ==== Nothing to do ...
354* ... for an empty active block ... ====
355 ns = 0
356 nd = 0
357 work( 1 ) = one
358 IF( ktop.GT.kbot )
359 $ RETURN
360* ... nor for an empty deflation window. ====
361 IF( nw.LT.1 )
362 $ RETURN
363*
364* ==== Machine constants ====
365*
366 safmin = slamch( 'SAFE MINIMUM' )
367 safmax = rone / safmin
368 CALL slabad( safmin, safmax )
369 ulp = slamch( 'PRECISION' )
370 smlnum = safmin*( real( n ) / ulp )
371*
372* ==== Setup deflation window ====
373*
374 jw = min( nw, kbot-ktop+1 )
375 kwtop = kbot - jw + 1
376 IF( kwtop.EQ.ktop ) THEN
377 s = zero
378 ELSE
379 s = h( kwtop, kwtop-1 )
380 END IF
381*
382 IF( kbot.EQ.kwtop ) THEN
383*
384* ==== 1-by-1 deflation window: not much to do ====
385*
386 sh( kwtop ) = h( kwtop, kwtop )
387 ns = 1
388 nd = 0
389 IF( cabs1( s ).LE.max( smlnum, ulp*cabs1( h( kwtop,
390 $ kwtop ) ) ) ) THEN
391 ns = 0
392 nd = 1
393 IF( kwtop.GT.ktop )
394 $ h( kwtop, kwtop-1 ) = zero
395 END IF
396 work( 1 ) = one
397 RETURN
398 END IF
399*
400* ==== Convert to spike-triangular form. (In case of a
401* . rare QR failure, this routine continues to do
402* . aggressive early deflation using that part of
403* . the deflation window that converged using INFQR
404* . here and there to keep track.) ====
405*
406 CALL clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt )
407 CALL ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 )
408*
409 CALL claset( 'A', jw, jw, zero, one, v, ldv )
410 nmin = ilaenv( 12, 'CLAQR3', 'SV', jw, 1, jw, lwork )
411 IF( jw.GT.nmin ) THEN
412 CALL claqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
413 $ jw, v, ldv, work, lwork, infqr )
414 ELSE
415 CALL clahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,
416 $ jw, v, ldv, infqr )
417 END IF
418*
419* ==== Deflation detection loop ====
420*
421 ns = jw
422 ilst = infqr + 1
423 DO 10 knt = infqr + 1, jw
424*
425* ==== Small spike tip deflation test ====
426*
427 foo = cabs1( t( ns, ns ) )
428 IF( foo.EQ.rzero )
429 $ foo = cabs1( s )
430 IF( cabs1( s )*cabs1( v( 1, ns ) ).LE.max( smlnum, ulp*foo ) )
431 $ THEN
432*
433* ==== One more converged eigenvalue ====
434*
435 ns = ns - 1
436 ELSE
437*
438* ==== One undeflatable eigenvalue. Move it up out of the
439* . way. (CTREXC can not fail in this case.) ====
440*
441 ifst = ns
442 CALL ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
443 ilst = ilst + 1
444 END IF
445 10 CONTINUE
446*
447* ==== Return to Hessenberg form ====
448*
449 IF( ns.EQ.0 )
450 $ s = zero
451*
452 IF( ns.LT.jw ) THEN
453*
454* ==== sorting the diagonal of T improves accuracy for
455* . graded matrices. ====
456*
457 DO 30 i = infqr + 1, ns
458 ifst = i
459 DO 20 j = i + 1, ns
460 IF( cabs1( t( j, j ) ).GT.cabs1( t( ifst, ifst ) ) )
461 $ ifst = j
462 20 CONTINUE
463 ilst = i
464 IF( ifst.NE.ilst )
465 $ CALL ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info )
466 30 CONTINUE
467 END IF
468*
469* ==== Restore shift/eigenvalue array from T ====
470*
471 DO 40 i = infqr + 1, jw
472 sh( kwtop+i-1 ) = t( i, i )
473 40 CONTINUE
474*
475*
476 IF( ns.LT.jw .OR. s.EQ.zero ) THEN
477 IF( ns.GT.1 .AND. s.NE.zero ) THEN
478*
479* ==== Reflect spike back into lower triangle ====
480*
481 CALL ccopy( ns, v, ldv, work, 1 )
482 DO 50 i = 1, ns
483 work( i ) = conjg( work( i ) )
484 50 CONTINUE
485 beta = work( 1 )
486 CALL clarfg( ns, beta, work( 2 ), 1, tau )
487 work( 1 ) = one
488*
489 CALL claset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt )
490*
491 CALL clarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,
492 $ work( jw+1 ) )
493 CALL clarf( 'R', ns, ns, work, 1, tau, t, ldt,
494 $ work( jw+1 ) )
495 CALL clarf( 'R', jw, ns, work, 1, tau, v, ldv,
496 $ work( jw+1 ) )
497*
498 CALL cgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),
499 $ lwork-jw, info )
500 END IF
501*
502* ==== Copy updated reduced window into place ====
503*
504 IF( kwtop.GT.1 )
505 $ h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) )
506 CALL clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh )
507 CALL ccopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),
508 $ ldh+1 )
509*
510* ==== Accumulate orthogonal matrix in order update
511* . H and Z, if requested. ====
512*
513 IF( ns.GT.1 .AND. s.NE.zero )
514 $ CALL cunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, v, ldv,
515 $ work( jw+1 ), lwork-jw, info )
516*
517* ==== Update vertical slab in H ====
518*
519 IF( wantt ) THEN
520 ltop = 1
521 ELSE
522 ltop = ktop
523 END IF
524 DO 60 krow = ltop, kwtop - 1, nv
525 kln = min( nv, kwtop-krow )
526 CALL cgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),
527 $ ldh, v, ldv, zero, wv, ldwv )
528 CALL clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh )
529 60 CONTINUE
530*
531* ==== Update horizontal slab in H ====
532*
533 IF( wantt ) THEN
534 DO 70 kcol = kbot + 1, n, nh
535 kln = min( nh, n-kcol+1 )
536 CALL cgemm( 'C', 'N', jw, kln, jw, one, v, ldv,
537 $ h( kwtop, kcol ), ldh, zero, t, ldt )
538 CALL clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),
539 $ ldh )
540 70 CONTINUE
541 END IF
542*
543* ==== Update vertical slab in Z ====
544*
545 IF( wantz ) THEN
546 DO 80 krow = iloz, ihiz, nv
547 kln = min( nv, ihiz-krow+1 )
548 CALL cgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),
549 $ ldz, v, ldv, zero, wv, ldwv )
550 CALL clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),
551 $ ldz )
552 80 CONTINUE
553 END IF
554 END IF
555*
556* ==== Return the number of deflations ... ====
557*
558 nd = jw - ns
559*
560* ==== ... and the number of shifts. (Subtracting
561* . INFQR from the spike length takes care
562* . of the case of a rare QR failure while
563* . calculating eigenvalues of the deflation
564* . window.) ====
565*
566 ns = ns - infqr
567*
568* ==== Return optimal workspace. ====
569*
570 work( 1 ) = cmplx( lwkopt, 0 )
571*
572* ==== End of CLAQR3 ====
573*

◆ claqr4()

subroutine claqr4 ( logical wantt,
logical wantz,
integer n,
integer ilo,
integer ihi,
complex, dimension( ldh, * ) h,
integer ldh,
complex, dimension( * ) w,
integer iloz,
integer ihiz,
complex, dimension( ldz, * ) z,
integer ldz,
complex, dimension( * ) work,
integer lwork,
integer info )

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

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

Purpose:
!>
!>    CLAQR4 implements one level of recursion for CLAQR0.
!>    It is a complete implementation of the small bulge multi-shift
!>    QR algorithm.  It may be called by CLAQR0 and, for large enough
!>    deflation window size, it may be called by CLAQR3.  This
!>    subroutine is identical to CLAQR0 except that it calls CLAQR2
!>    instead of CLAQR3.
!>
!>    CLAQR4 computes the eigenvalues of a Hessenberg matrix H
!>    and, optionally, the matrices T and Z from the Schur decomposition
!>    H = Z T Z**H, where T is an upper triangular matrix (the
!>    Schur form), and Z is the unitary matrix of Schur vectors.
!>
!>    Optionally Z may be postmultiplied into an input unitary
!>    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 unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
!>
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 CGEBAL, and then passed to CGEHRD when the
!>           matrix output by CGEBAL 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 COMPLEX 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 triangular matrix T from the Schur
!>           decomposition (the Schur form). If INFO = 0 and WANT 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]W
!>          W is COMPLEX array, dimension (N)
!>           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
!>           in W(ILO:IHI). 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 W(i) = H(i,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 COMPLEX 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 COMPLEX 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 CLAQR4 does a workspace query.
!>           In this case, CLAQR4 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, CLAQR4 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 unitary 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 unitary 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 246 of file claqr4.f.

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

◆ claqr5()

subroutine claqr5 ( logical wantt,
logical wantz,
integer kacc22,
integer n,
integer ktop,
integer kbot,
integer nshfts,
complex, dimension( * ) s,
complex, dimension( ldh, * ) h,
integer ldh,
integer iloz,
integer ihiz,
complex, dimension( ldz, * ) z,
integer ldz,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( ldu, * ) u,
integer ldu,
integer nv,
complex, dimension( ldwv, * ) wv,
integer ldwv,
integer nh,
complex, dimension( ldwh, * ) wh,
integer ldwh )

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

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

Purpose:
!>
!>    CLAQR5 called by CLAQR0 performs a
!>    single small-bulge multi-shift QR sweep.
!>
Parameters
[in]WANTT
!>          WANTT is LOGICAL
!>             WANTT = .true. if the triangular Schur factor
!>             is being computed.  WANTT is set to .false. otherwise.
!>
[in]WANTZ
!>          WANTZ is LOGICAL
!>             WANTZ = .true. if the unitary 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: CLAQR5 does not accumulate reflections and does not
!>             use matrix-matrix multiply to update far-from-diagonal
!>             matrix entries.
!>        = 1: CLAQR5 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]S
!>          S is COMPLEX array, dimension (NSHFTS)
!>             S contains the shifts of origin that define the multi-
!>             shift QR sweep.  On output S may be reordered.
!>
[in,out]H
!>          H is COMPLEX 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 COMPLEX array, dimension (LDZ,IHIZ)
!>             If WANTZ = .TRUE., then the QR Sweep unitary
!>             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 COMPLEX 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 COMPLEX 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 COMPLEX 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 COMPLEX 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 254 of file claqr5.f.

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

◆ claqsb()

subroutine claqsb ( character uplo,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) s,
real scond,
real amax,
character equed )

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

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

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

◆ claqsp()

subroutine claqsp ( character uplo,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) s,
real scond,
real amax,
character equed )

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

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

Purpose:
!>
!> CLAQSP 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 COMPLEX 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 REAL array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is REAL
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is REAL
!>          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 125 of file claqsp.f.

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

◆ clar1v()

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

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

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

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

◆ clar2v()

subroutine clar2v ( integer n,
complex, dimension( * ) x,
complex, dimension( * ) y,
complex, dimension( * ) z,
integer incx,
real, dimension( * ) c,
complex, dimension( * ) s,
integer incc )

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

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

Purpose:
!>
!> CLAR2V applies a vector of complex plane rotations with real cosines
!> from both sides to a sequence of 2-by-2 complex Hermitian matrices,
!> defined by the elements of the vectors x, y and z. For i = 1,2,...,n
!>
!>    (       x(i)  z(i) ) :=
!>    ( conjg(z(i)) y(i) )
!>
!>      (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )
!>      ( -s(i)       c(i)  ) ( conjg(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 COMPLEX array, dimension (1+(N-1)*INCX)
!>          The vector x; the elements of x are assumed to be real.
!>
[in,out]Y
!>          Y is COMPLEX array, dimension (1+(N-1)*INCX)
!>          The vector y; the elements of y are assumed to be real.
!>
[in,out]Z
!>          Z is COMPLEX 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 REAL array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is COMPLEX 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 110 of file clar2v.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 INTEGER INCC, INCX, N
118* ..
119* .. Array Arguments ..
120 REAL C( * )
121 COMPLEX S( * ), X( * ), Y( * ), Z( * )
122* ..
123*
124* =====================================================================
125*
126* .. Local Scalars ..
127 INTEGER I, IC, IX
128 REAL CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
129 $ ZIR
130 COMPLEX SI, T2, T3, T4, ZI
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC aimag, cmplx, conjg, real
134* ..
135* .. Executable Statements ..
136*
137 ix = 1
138 ic = 1
139 DO 10 i = 1, n
140 xi = real( x( ix ) )
141 yi = real( y( ix ) )
142 zi = z( ix )
143 zir = real( zi )
144 zii = aimag( zi )
145 ci = c( ic )
146 si = s( ic )
147 sir = real( si )
148 sii = aimag( si )
149 t1r = sir*zir - sii*zii
150 t1i = sir*zii + sii*zir
151 t2 = ci*zi
152 t3 = t2 - conjg( si )*xi
153 t4 = conjg( t2 ) + si*yi
154 t5 = ci*xi + t1r
155 t6 = ci*yi - t1r
156 x( ix ) = ci*t5 + ( sir*real( t4 )+sii*aimag( t4 ) )
157 y( ix ) = ci*t6 - ( sir*real( t3 )-sii*aimag( t3 ) )
158 z( ix ) = ci*t3 + conjg( si )*cmplx( t6, t1i )
159 ix = ix + incx
160 ic = ic + incc
161 10 CONTINUE
162 RETURN
163*
164* End of CLAR2V
165*

◆ clarcm()

subroutine clarcm ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork )

CLARCM copies all or part of a real two-dimensional array to a complex array.

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

Purpose:
!>
!> CLARCM performs a very simple matrix-matrix multiplication:
!>          C := A * B,
!> where A is M by M and real; B is M by N and complex;
!> C is M by N and complex.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A and of the matrix C.
!>          M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns and rows of the matrix B and
!>          the number of columns of the matrix C.
!>          N >= 0.
!>
[in]A
!>          A is REAL array, dimension (LDA, M)
!>          On entry, A contains the M by M matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >=max(1,M).
!>
[in]B
!>          B is COMPLEX array, dimension (LDB, N)
!>          On entry, B contains the M by N matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >=max(1,M).
!>
[out]C
!>          C is COMPLEX array, dimension (LDC, N)
!>          On exit, C contains the M by N matrix C.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >=max(1,M).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (2*M*N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file clarcm.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 INTEGER LDA, LDB, LDC, M, N
121* ..
122* .. Array Arguments ..
123 REAL A( LDA, * ), RWORK( * )
124 COMPLEX B( LDB, * ), C( LDC, * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 REAL ONE, ZERO
131 parameter( one = 1.0e0, zero = 0.0e0 )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC aimag, cmplx, real
138* ..
139* .. External Subroutines ..
140 EXTERNAL sgemm
141* ..
142* .. Executable Statements ..
143*
144* Quick return if possible.
145*
146 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
147 $ RETURN
148*
149 DO 20 j = 1, n
150 DO 10 i = 1, m
151 rwork( ( j-1 )*m+i ) = real( b( i, j ) )
152 10 CONTINUE
153 20 CONTINUE
154*
155 l = m*n + 1
156 CALL sgemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,
157 $ rwork( l ), m )
158 DO 40 j = 1, n
159 DO 30 i = 1, m
160 c( i, j ) = rwork( l+( j-1 )*m+i-1 )
161 30 CONTINUE
162 40 CONTINUE
163*
164 DO 60 j = 1, n
165 DO 50 i = 1, m
166 rwork( ( j-1 )*m+i ) = aimag( b( i, j ) )
167 50 CONTINUE
168 60 CONTINUE
169 CALL sgemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,
170 $ rwork( l ), m )
171 DO 80 j = 1, n
172 DO 70 i = 1, m
173 c( i, j ) = cmplx( real( c( i, j ) ),
174 $ rwork( l+( j-1 )*m+i-1 ) )
175 70 CONTINUE
176 80 CONTINUE
177*
178 RETURN
179*
180* End of CLARCM
181*

◆ clarf()

subroutine clarf ( character side,
integer m,
integer n,
complex, dimension( * ) v,
integer incv,
complex tau,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) work )

CLARF applies an elementary reflector to a general rectangular matrix.

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

Purpose:
!>
!> CLARF applies a complex elementary reflector H to a complex M-by-N
!> matrix C, from either the left or the right. H is represented in the
!> form
!>
!>       H = I - tau * v * v**H
!>
!> where tau is a complex scalar and v is a complex vector.
!>
!> If tau = 0, then H is taken to be the unit matrix.
!>
!> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
!> tau.
!>
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 COMPLEX 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 COMPLEX
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is COMPLEX 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 COMPLEX 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 127 of file clarf.f.

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

◆ clarfb()

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

CLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.

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

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

◆ clarfb_gett()

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

CLARFB_GETT

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

Purpose:
!>
!> CLARFB_GETT applies a complex Householder block reflector H from the
!> left to a complex (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 COMPLEX 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 COMPLEX 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 COMPLEX 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 COMPLEX 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**H ) * ( A_in ) =
!>       ( B_out )        ( B_in )                          ( B_in )
!>                  = ( I - ( V1 ) * T * ( V1**H, V2**H ) ) * ( 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**H ) * ( A1_in )
!>       ( B1_out )        (     0 )                          (     0 )
!>
!>       ( A2_out ) := H * ( A2_in ) = ( I - V * T * V**H ) * ( A2_in )
!>       ( B2_out )        ( B2_in )                          ( B2_in )
!>
!>    If IDENT != 'I':
!>
!>       The computation for column block 1:
!>
!>       A1_out: = A1_in - V1*T*(V1**H)*A1_in
!>
!>       B1_out: = - V2*T*(V1**H)*A1_in
!>
!>       The computation for column block 2, which exists if N > K:
!>
!>       A2_out: = A2_in - V1*T*( (V1**H)*A2_in + (V2**H)*B2_in )
!>
!>       B2_out: = B2_in - V2*T*( (V1**H)*A2_in + (V2**H)*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**H)*B2_in )
!>
!>       B2_out: = B2_in - V2*T*( A2_in + (V2**H)*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**H) * W2 = (unit_lower_tr_of_(A1)**H) * W2
!>       col2_(3) W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * 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**H) * W1 = (unit_lower_tr_of_(A1)**H) * 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**H) * B2 = W2 + (B1**H) * 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**H) * W2
!>                      = (unit_lower_tr_of_(A1)**H) * W2
!>      end if
!>      col2_(3)  W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * 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**H) * W1
!>                    = (unit_lower_tr_of_(A1)**H) * 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 clarfb_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 COMPLEX A( LDA, * ), B( LDB, * ), T( LDT, * ),
404 $ WORK( LDWORK, * )
405* ..
406*
407* =====================================================================
408*
409* .. Parameters ..
410 COMPLEX CONE, CZERO
411 parameter( cone = ( 1.0e+0, 0.0e+0 ),
412 $ czero = ( 0.0e+0, 0.0e+0 ) )
413* ..
414* .. Local Scalars ..
415 LOGICAL LNOTIDENT
416 INTEGER I, J
417* ..
418* .. EXTERNAL FUNCTIONS ..
419 LOGICAL LSAME
420 EXTERNAL lsame
421* ..
422* .. External Subroutines ..
423 EXTERNAL ccopy, cgemm, ctrmm
424* ..
425* .. Executable Statements ..
426*
427* Quick return if possible
428*
429 IF( m.LT.0 .OR. n.LE.0 .OR. k.EQ.0 .OR. k.GT.n )
430 $ RETURN
431*
432 lnotident = .NOT.lsame( ident, 'I' )
433*
434* ------------------------------------------------------------------
435*
436* First Step. Computation of the Column Block 2:
437*
438* ( A2 ) := H * ( A2 )
439* ( B2 ) ( B2 )
440*
441* ------------------------------------------------------------------
442*
443 IF( n.GT.k ) THEN
444*
445* col2_(1) Compute W2: = A2. Therefore, copy A2 = A(1:K, K+1:N)
446* into W2=WORK(1:K, 1:N-K) column-by-column.
447*
448 DO j = 1, n-k
449 CALL ccopy( k, a( 1, k+j ), 1, work( 1, j ), 1 )
450 END DO
451
452 IF( lnotident ) THEN
453*
454* col2_(2) Compute W2: = (V1**H) * W2 = (A1**H) * W2,
455* V1 is not an identy matrix, but unit lower-triangular
456* V1 stored in A1 (diagonal ones are not stored).
457*
458*
459 CALL ctrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,
460 $ work, ldwork )
461 END IF
462*
463* col2_(3) Compute W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * B2
464* V2 stored in B1.
465*
466 IF( m.GT.0 ) THEN
467 CALL cgemm( 'C', 'N', k, n-k, m, cone, b, ldb,
468 $ b( 1, k+1 ), ldb, cone, work, ldwork )
469 END IF
470*
471* col2_(4) Compute W2: = T * W2,
472* T is upper-triangular.
473*
474 CALL ctrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,
475 $ work, ldwork )
476*
477* col2_(5) Compute B2: = B2 - V2 * W2 = B2 - B1 * W2,
478* V2 stored in B1.
479*
480 IF( m.GT.0 ) THEN
481 CALL cgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,
482 $ work, ldwork, cone, b( 1, k+1 ), ldb )
483 END IF
484*
485 IF( lnotident ) THEN
486*
487* col2_(6) Compute W2: = V1 * W2 = A1 * W2,
488* V1 is not an identity matrix, but unit lower-triangular,
489* V1 stored in A1 (diagonal ones are not stored).
490*
491 CALL ctrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,
492 $ work, ldwork )
493 END IF
494*
495* col2_(7) Compute A2: = A2 - W2 =
496* = A(1:K, K+1:N-K) - WORK(1:K, 1:N-K),
497* column-by-column.
498*
499 DO j = 1, n-k
500 DO i = 1, k
501 a( i, k+j ) = a( i, k+j ) - work( i, j )
502 END DO
503 END DO
504*
505 END IF
506*
507* ------------------------------------------------------------------
508*
509* Second Step. Computation of the Column Block 1:
510*
511* ( A1 ) := H * ( A1 )
512* ( B1 ) ( 0 )
513*
514* ------------------------------------------------------------------
515*
516* col1_(1) Compute W1: = A1. Copy the upper-triangular
517* A1 = A(1:K, 1:K) into the upper-triangular
518* W1 = WORK(1:K, 1:K) column-by-column.
519*
520 DO j = 1, k
521 CALL ccopy( j, a( 1, j ), 1, work( 1, j ), 1 )
522 END DO
523*
524* Set the subdiagonal elements of W1 to zero column-by-column.
525*
526 DO j = 1, k - 1
527 DO i = j + 1, k
528 work( i, j ) = czero
529 END DO
530 END DO
531*
532 IF( lnotident ) THEN
533*
534* col1_(2) Compute W1: = (V1**H) * W1 = (A1**H) * W1,
535* V1 is not an identity matrix, but unit lower-triangular
536* V1 stored in A1 (diagonal ones are not stored),
537* W1 is upper-triangular with zeroes below the diagonal.
538*
539 CALL ctrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,
540 $ work, ldwork )
541 END IF
542*
543* col1_(3) Compute W1: = T * W1,
544* T is upper-triangular,
545* W1 is upper-triangular with zeroes below the diagonal.
546*
547 CALL ctrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,
548 $ work, ldwork )
549*
550* col1_(4) Compute B1: = - V2 * W1 = - B1 * W1,
551* V2 = B1, W1 is upper-triangular with zeroes below the diagonal.
552*
553 IF( m.GT.0 ) THEN
554 CALL ctrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,
555 $ b, ldb )
556 END IF
557*
558 IF( lnotident ) THEN
559*
560* col1_(5) Compute W1: = V1 * W1 = A1 * W1,
561* V1 is not an identity matrix, but unit lower-triangular
562* V1 stored in A1 (diagonal ones are not stored),
563* W1 is upper-triangular on input with zeroes below the diagonal,
564* and square on output.
565*
566 CALL ctrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,
567 $ work, ldwork )
568*
569* col1_(6) Compute A1: = A1 - W1 = A(1:K, 1:K) - WORK(1:K, 1:K)
570* column-by-column. A1 is upper-triangular on input.
571* If IDENT, A1 is square on output, and W1 is square,
572* if NOT IDENT, A1 is upper-triangular on output,
573* W1 is upper-triangular.
574*
575* col1_(6)_a Compute elements of A1 below the diagonal.
576*
577 DO j = 1, k - 1
578 DO i = j + 1, k
579 a( i, j ) = - work( i, j )
580 END DO
581 END DO
582*
583 END IF
584*
585* col1_(6)_b Compute elements of A1 on and above the diagonal.
586*
587 DO j = 1, k
588 DO i = 1, j
589 a( i, j ) = a( i, j ) - work( i, j )
590 END DO
591 END DO
592*
593 RETURN
594*
595* End of CLARFB_GETT
596*

◆ clarfg()

subroutine clarfg ( integer n,
complex alpha,
complex, dimension( * ) x,
integer incx,
complex tau )

CLARFG generates an elementary reflector (Householder matrix).

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

Purpose:
!>
!> CLARFG generates a complex elementary reflector H of order n, such
!> that
!>
!>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
!>              (   x   )   (   0  )
!>
!> where alpha and beta are scalars, with beta real, and x is an
!> (n-1)-element complex vector. H is represented in the form
!>
!>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
!>                     ( v )
!>
!> where tau is a complex scalar and v is a complex (n-1)-element
!> vector. Note that H is not hermitian.
!>
!> If the elements of x are all zero and alpha is real, then tau = 0
!> and H is taken to be the unit matrix.
!>
!> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the elementary reflector.
!>
[in,out]ALPHA
!>          ALPHA is COMPLEX
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is COMPLEX 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 COMPLEX
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file clarfg.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 COMPLEX ALPHA, TAU
114* ..
115* .. Array Arguments ..
116 COMPLEX X( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 REAL ONE, ZERO
123 parameter( one = 1.0e+0, zero = 0.0e+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER J, KNT
127 REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
128* ..
129* .. External Functions ..
130 REAL SCNRM2, SLAMCH, SLAPY3
131 COMPLEX CLADIV
132 EXTERNAL scnrm2, slamch, slapy3, cladiv
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC abs, aimag, cmplx, real, sign
136* ..
137* .. External Subroutines ..
138 EXTERNAL cscal, csscal
139* ..
140* .. Executable Statements ..
141*
142 IF( n.LE.0 ) THEN
143 tau = zero
144 RETURN
145 END IF
146*
147 xnorm = scnrm2( n-1, x, incx )
148 alphr = real( alpha )
149 alphi = aimag( alpha )
150*
151 IF( xnorm.EQ.zero .AND. alphi.EQ.zero ) THEN
152*
153* H = I
154*
155 tau = zero
156 ELSE
157*
158* general case
159*
160 beta = -sign( slapy3( alphr, alphi, xnorm ), alphr )
161 safmin = slamch( 'S' ) / slamch( 'E' )
162 rsafmn = one / safmin
163*
164 knt = 0
165 IF( abs( beta ).LT.safmin ) THEN
166*
167* XNORM, BETA may be inaccurate; scale X and recompute them
168*
169 10 CONTINUE
170 knt = knt + 1
171 CALL csscal( n-1, rsafmn, x, incx )
172 beta = beta*rsafmn
173 alphi = alphi*rsafmn
174 alphr = alphr*rsafmn
175 IF( (abs( beta ).LT.safmin) .AND. (knt .LT. 20) )
176 $ GO TO 10
177*
178* New BETA is at most 1, at least SAFMIN
179*
180 xnorm = scnrm2( n-1, x, incx )
181 alpha = cmplx( alphr, alphi )
182 beta = -sign( slapy3( alphr, alphi, xnorm ), alphr )
183 END IF
184 tau = cmplx( ( beta-alphr ) / beta, -alphi / beta )
185 alpha = cladiv( cmplx( one ), alpha-beta )
186 CALL cscal( n-1, alpha, x, incx )
187*
188* If ALPHA is subnormal, it may lose relative accuracy
189*
190 DO 20 j = 1, knt
191 beta = beta*safmin
192 20 CONTINUE
193 alpha = beta
194 END IF
195*
196 RETURN
197*
198* End of CLARFG
199*
slapy3
real function slapy3(x, y, z)
SLAPY3 returns sqrt(x2+y2+z2).
Definition slapy3.f:68

◆ clarfgp()

subroutine clarfgp ( integer n,
complex alpha,
complex, dimension( * ) x,
integer incx,
complex tau )

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

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

Purpose:
!>
!> CLARFGP generates a complex elementary reflector H of order n, such
!> that
!>
!>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
!>              (   x   )   (   0  )
!>
!> where alpha and beta are scalars, beta is real and non-negative, and
!> x is an (n-1)-element complex vector.  H is represented in the form
!>
!>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
!>                     ( v )
!>
!> where tau is a complex scalar and v is a complex (n-1)-element
!> vector. Note that H is not hermitian.
!>
!> If the elements of x are all zero and alpha is real, 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 COMPLEX
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is COMPLEX 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 COMPLEX
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file clarfgp.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 COMPLEX ALPHA, TAU
112* ..
113* .. Array Arguments ..
114 COMPLEX X( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 REAL TWO, ONE, ZERO
121 parameter( two = 2.0e+0, one = 1.0e+0, zero = 0.0e+0 )
122* ..
123* .. Local Scalars ..
124 INTEGER J, KNT
125 REAL ALPHI, ALPHR, BETA, BIGNUM, SMLNUM, XNORM
126 COMPLEX SAVEALPHA
127* ..
128* .. External Functions ..
129 REAL SCNRM2, SLAMCH, SLAPY3, SLAPY2
130 COMPLEX CLADIV
131 EXTERNAL scnrm2, slamch, slapy3, slapy2, cladiv
132* ..
133* .. Intrinsic Functions ..
134 INTRINSIC abs, aimag, cmplx, real, sign
135* ..
136* .. External Subroutines ..
137 EXTERNAL cscal, csscal
138* ..
139* .. Executable Statements ..
140*
141 IF( n.LE.0 ) THEN
142 tau = zero
143 RETURN
144 END IF
145*
146 xnorm = scnrm2( n-1, x, incx )
147 alphr = real( alpha )
148 alphi = aimag( alpha )
149*
150 IF( xnorm.EQ.zero ) THEN
151*
152* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0.
153*
154 IF( alphi.EQ.zero ) THEN
155 IF( alphr.GE.zero ) THEN
156* When TAU.eq.ZERO, the vector is special-cased to be
157* all zeros in the application routines. We do not need
158* to clear it.
159 tau = zero
160 ELSE
161* However, the application routines rely on explicit
162* zero checks when TAU.ne.ZERO, and we must clear X.
163 tau = two
164 DO j = 1, n-1
165 x( 1 + (j-1)*incx ) = zero
166 END DO
167 alpha = -alpha
168 END IF
169 ELSE
170* Only "reflecting" the diagonal entry to be real and non-negative.
171 xnorm = slapy2( alphr, alphi )
172 tau = cmplx( one - alphr / xnorm, -alphi / xnorm )
173 DO j = 1, n-1
174 x( 1 + (j-1)*incx ) = zero
175 END DO
176 alpha = xnorm
177 END IF
178 ELSE
179*
180* general case
181*
182 beta = sign( slapy3( alphr, alphi, xnorm ), alphr )
183 smlnum = slamch( 'S' ) / slamch( 'E' )
184 bignum = one / smlnum
185*
186 knt = 0
187 IF( abs( beta ).LT.smlnum ) THEN
188*
189* XNORM, BETA may be inaccurate; scale X and recompute them
190*
191 10 CONTINUE
192 knt = knt + 1
193 CALL csscal( n-1, bignum, x, incx )
194 beta = beta*bignum
195 alphi = alphi*bignum
196 alphr = alphr*bignum
197 IF( (abs( beta ).LT.smlnum) .AND. (knt .LT. 20) )
198 $ GO TO 10
199*
200* New BETA is at most 1, at least SMLNUM
201*
202 xnorm = scnrm2( n-1, x, incx )
203 alpha = cmplx( alphr, alphi )
204 beta = sign( slapy3( alphr, alphi, xnorm ), alphr )
205 END IF
206 savealpha = alpha
207 alpha = alpha + beta
208 IF( beta.LT.zero ) THEN
209 beta = -beta
210 tau = -alpha / beta
211 ELSE
212 alphr = alphi * (alphi/real( alpha ))
213 alphr = alphr + xnorm * (xnorm/real( alpha ))
214 tau = cmplx( alphr/beta, -alphi/beta )
215 alpha = cmplx( -alphr, alphi )
216 END IF
217 alpha = cladiv( cmplx( one ), alpha )
218*
219 IF ( abs(tau).LE.smlnum ) THEN
220*
221* In the case where the computed TAU ends up being a denormalized number,
222* it loses relative accuracy. This is a BIG problem. Solution: flush TAU
223* to ZERO (or TWO or whatever makes a nonnegative real number for BETA).
224*
225* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.)
226* (Thanks Pat. Thanks MathWorks.)
227*
228 alphr = real( savealpha )
229 alphi = aimag( savealpha )
230 IF( alphi.EQ.zero ) THEN
231 IF( alphr.GE.zero ) THEN
232 tau = zero
233 ELSE
234 tau = two
235 DO j = 1, n-1
236 x( 1 + (j-1)*incx ) = zero
237 END DO
238 beta = real( -savealpha )
239 END IF
240 ELSE
241 xnorm = slapy2( alphr, alphi )
242 tau = cmplx( one - alphr / xnorm, -alphi / xnorm )
243 DO j = 1, n-1
244 x( 1 + (j-1)*incx ) = zero
245 END DO
246 beta = xnorm
247 END IF
248*
249 ELSE
250*
251* This is the general case.
252*
253 CALL cscal( n-1, alpha, x, incx )
254*
255 END IF
256*
257* If BETA is subnormal, it may lose relative accuracy
258*
259 DO 20 j = 1, knt
260 beta = beta*smlnum
261 20 CONTINUE
262 alpha = beta
263 END IF
264*
265 RETURN
266*
267* End of CLARFGP
268*
slapy2
real function slapy2(x, y)
SLAPY2 returns sqrt(x2+y2).
Definition slapy2.f:63

◆ clarft()

subroutine clarft ( character direct,
character storev,
integer n,
integer k,
complex, dimension( ldv, * ) v,
integer ldv,
complex, dimension( * ) tau,
complex, dimension( ldt, * ) t,
integer ldt )

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

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

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

◆ clarfx()

subroutine clarfx ( character side,
integer m,
integer n,
complex, dimension( * ) v,
complex tau,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) work )

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

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

Purpose:
!>
!> CLARFX applies a complex elementary reflector H to a complex m by n
!> matrix C, from either the left or the right. H is represented in the
!> form
!>
!>       H = I - tau * v * v**H
!>
!> where tau is a complex scalar and v is a complex 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 COMPLEX array, dimension (M) if SIDE = 'L'
!>                                        or (N) if SIDE = 'R'
!>          The vector v in the representation of H.
!>
[in]TAU
!>          TAU is COMPLEX
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is COMPLEX 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 COMPLEX 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 118 of file clarfx.f.

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

◆ clarfy()

subroutine clarfy ( character uplo,
integer n,
complex, dimension( * ) v,
integer incv,
complex tau,
complex, dimension( ldc, * ) c,
integer ldc,
complex, dimension( * ) work )

CLARFY

Purpose:
!>
!> CLARFY applies an elementary reflector, or Householder matrix, H,
!> to an n x n Hermitian 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
!>          Hermitian 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 COMPLEX 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 COMPLEX
!>          The value tau as described above.
!>
[in,out]C
!>          C is COMPLEX 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 COMPLEX array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file clarfy.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 COMPLEX TAU
117* ..
118* .. Array Arguments ..
119 COMPLEX C( LDC, * ), V( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 COMPLEX ONE, ZERO, HALF
126 parameter( one = ( 1.0e+0, 0.0e+0 ),
127 $ zero = ( 0.0e+0, 0.0e+0 ),
128 $ half = ( 0.5e+0, 0.0e+0 ) )
129* ..
130* .. Local Scalars ..
131 COMPLEX ALPHA
132* ..
133* .. External Subroutines ..
134 EXTERNAL caxpy, chemv, cher2
135* ..
136* .. External Functions ..
137 COMPLEX CDOTC
138 EXTERNAL cdotc
139* ..
140* .. Executable Statements ..
141*
142 IF( tau.EQ.zero )
143 $ RETURN
144*
145* Form w:= C * v
146*
147 CALL chemv( uplo, n, one, c, ldc, v, incv, zero, work, 1 )
148*
149 alpha = -half*tau*cdotc( n, work, 1, v, incv )
150 CALL caxpy( n, alpha, v, incv, work, 1 )
151*
152* C := C - v * w' - w * v'
153*
154 CALL cher2( uplo, n, -tau, v, incv, work, 1, c, ldc )
155*
156 RETURN
157*
158* End of CLARFY
159*
chemv
subroutine chemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
CHEMV
Definition chemv.f:154
cher2
subroutine cher2(uplo, n, alpha, x, incx, y, incy, a, lda)
CHER2
Definition cher2.f:150

◆ clargv()

subroutine clargv ( integer n,
complex, dimension( * ) x,
integer incx,
complex, dimension( * ) y,
integer incy,
real, dimension( * ) c,
integer incc )

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

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

Purpose:
!>
!> CLARGV generates a vector of complex plane rotations with real
!> cosines, determined by elements of the complex vectors x and y.
!> For i = 1,2,...,n
!>
!>    (        c(i)   s(i) ) ( x(i) ) = ( r(i) )
!>    ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )
!>
!>    where c(i)**2 + ABS(s(i))**2 = 1
!>
!> The following conventions are used (these are the same as in CLARTG,
!> but differ from the BLAS1 routine CROTG):
!>    If y(i)=0, then c(i)=1 and s(i)=0.
!>    If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of plane rotations to be generated.
!>
[in,out]X
!>          X is COMPLEX array, dimension (1+(N-1)*INCX)
!>          On entry, the vector x.
!>          On exit, x(i) is overwritten by r(i), for i = 1,...,n.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X. INCX > 0.
!>
[in,out]Y
!>          Y is COMPLEX 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 REAL 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.
Further Details:
!>
!>  6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel
!>
!>  This version has a few statements commented out for thread safety
!>  (machine parameters are computed on each entry). 10 feb 03, SJH.
!>

Definition at line 121 of file clargv.f.

122*
123* -- LAPACK auxiliary routine --
124* -- LAPACK is a software package provided by Univ. of Tennessee, --
125* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
126*
127* .. Scalar Arguments ..
128 INTEGER INCC, INCX, INCY, N
129* ..
130* .. Array Arguments ..
131 REAL C( * )
132 COMPLEX X( * ), Y( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL TWO, ONE, ZERO
139 parameter( two = 2.0e+0, one = 1.0e+0, zero = 0.0e+0 )
140 COMPLEX CZERO
141 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
142* ..
143* .. Local Scalars ..
144* LOGICAL FIRST
145 INTEGER COUNT, I, IC, IX, IY, J
146 REAL CS, D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
147 $ SAFMN2, SAFMX2, SCALE
148 COMPLEX F, FF, FS, G, GS, R, SN
149* ..
150* .. External Functions ..
151 REAL SLAMCH, SLAPY2
152 EXTERNAL slamch, slapy2
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC abs, aimag, cmplx, conjg, int, log, max, real,
156 $ sqrt
157* ..
158* .. Statement Functions ..
159 REAL ABS1, ABSSQ
160* ..
161* .. Save statement ..
162* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
163* ..
164* .. Data statements ..
165* DATA FIRST / .TRUE. /
166* ..
167* .. Statement Function definitions ..
168 abs1( ff ) = max( abs( real( ff ) ), abs( aimag( ff ) ) )
169 abssq( ff ) = real( ff )**2 + aimag( ff )**2
170* ..
171* .. Executable Statements ..
172*
173* IF( FIRST ) THEN
174* FIRST = .FALSE.
175 safmin = slamch( 'S' )
176 eps = slamch( 'E' )
177 safmn2 = slamch( 'B' )**int( log( safmin / eps ) /
178 $ log( slamch( 'B' ) ) / two )
179 safmx2 = one / safmn2
180* END IF
181 ix = 1
182 iy = 1
183 ic = 1
184 DO 60 i = 1, n
185 f = x( ix )
186 g = y( iy )
187*
188* Use identical algorithm as in CLARTG
189*
190 scale = max( abs1( f ), abs1( g ) )
191 fs = f
192 gs = g
193 count = 0
194 IF( scale.GE.safmx2 ) THEN
195 10 CONTINUE
196 count = count + 1
197 fs = fs*safmn2
198 gs = gs*safmn2
199 scale = scale*safmn2
200 IF( scale.GE.safmx2 .AND. count .LT. 20 )
201 $ GO TO 10
202 ELSE IF( scale.LE.safmn2 ) THEN
203 IF( g.EQ.czero ) THEN
204 cs = one
205 sn = czero
206 r = f
207 GO TO 50
208 END IF
209 20 CONTINUE
210 count = count - 1
211 fs = fs*safmx2
212 gs = gs*safmx2
213 scale = scale*safmx2
214 IF( scale.LE.safmn2 )
215 $ GO TO 20
216 END IF
217 f2 = abssq( fs )
218 g2 = abssq( gs )
219 IF( f2.LE.max( g2, one )*safmin ) THEN
220*
221* This is a rare case: F is very small.
222*
223 IF( f.EQ.czero ) THEN
224 cs = zero
225 r = slapy2( real( g ), aimag( g ) )
226* Do complex/real division explicitly with two real
227* divisions
228 d = slapy2( real( gs ), aimag( gs ) )
229 sn = cmplx( real( gs ) / d, -aimag( gs ) / d )
230 GO TO 50
231 END IF
232 f2s = slapy2( real( fs ), aimag( fs ) )
233* G2 and G2S are accurate
234* G2 is at least SAFMIN, and G2S is at least SAFMN2
235 g2s = sqrt( g2 )
236* Error in CS from underflow in F2S is at most
237* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
238* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
239* and so CS .lt. sqrt(SAFMIN)
240* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
241* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
242* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
243 cs = f2s / g2s
244* Make sure abs(FF) = 1
245* Do complex/real division explicitly with 2 real divisions
246 IF( abs1( f ).GT.one ) THEN
247 d = slapy2( real( f ), aimag( f ) )
248 ff = cmplx( real( f ) / d, aimag( f ) / d )
249 ELSE
250 dr = safmx2*real( f )
251 di = safmx2*aimag( f )
252 d = slapy2( dr, di )
253 ff = cmplx( dr / d, di / d )
254 END IF
255 sn = ff*cmplx( real( gs ) / g2s, -aimag( gs ) / g2s )
256 r = cs*f + sn*g
257 ELSE
258*
259* This is the most common case.
260* Neither F2 nor F2/G2 are less than SAFMIN
261* F2S cannot overflow, and it is accurate
262*
263 f2s = sqrt( one+g2 / f2 )
264* Do the F2S(real)*FS(complex) multiply with two real
265* multiplies
266 r = cmplx( f2s*real( fs ), f2s*aimag( fs ) )
267 cs = one / f2s
268 d = f2 + g2
269* Do complex/real division explicitly with two real divisions
270 sn = cmplx( real( r ) / d, aimag( r ) / d )
271 sn = sn*conjg( gs )
272 IF( count.NE.0 ) THEN
273 IF( count.GT.0 ) THEN
274 DO 30 j = 1, count
275 r = r*safmx2
276 30 CONTINUE
277 ELSE
278 DO 40 j = 1, -count
279 r = r*safmn2
280 40 CONTINUE
281 END IF
282 END IF
283 END IF
284 50 CONTINUE
285 c( ic ) = cs
286 y( iy ) = sn
287 x( ix ) = r
288 ic = ic + incc
289 iy = iy + incy
290 ix = ix + incx
291 60 CONTINUE
292 RETURN
293*
294* End of CLARGV
295*

◆ clarnv()

subroutine clarnv ( integer idist,
integer, dimension( 4 ) iseed,
integer n,
complex, dimension( * ) x )

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

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

Purpose:
!>
!> CLARNV returns a vector of n random complex numbers from a uniform or
!> normal distribution.
!>
Parameters
[in]IDIST
!>          IDIST is INTEGER
!>          Specifies the distribution of the random numbers:
!>          = 1:  real and imaginary parts each uniform (0,1)
!>          = 2:  real and imaginary parts each uniform (-1,1)
!>          = 3:  real and imaginary parts each normal (0,1)
!>          = 4:  uniformly distributed on the disc abs(z) < 1
!>          = 5:  uniformly distributed on the circle abs(z) = 1
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed of the random number generator; the array
!>          elements must be between 0 and 4095, and ISEED(4) must be
!>          odd.
!>          On exit, the seed is updated.
!>
[in]N
!>          N is INTEGER
!>          The number of random numbers to be generated.
!>
[out]X
!>          X is COMPLEX array, dimension (N)
!>          The generated random numbers.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  This routine calls the auxiliary routine SLARUV to generate random
!>  real numbers from a uniform (0,1) distribution, in batches of up to
!>  128 using vectorisable code. The Box-Muller method is used to
!>  transform numbers from a uniform to a normal distribution.
!>

Definition at line 98 of file clarnv.f.

99*
100* -- LAPACK auxiliary routine --
101* -- LAPACK is a software package provided by Univ. of Tennessee, --
102* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
103*
104* .. Scalar Arguments ..
105 INTEGER IDIST, N
106* ..
107* .. Array Arguments ..
108 INTEGER ISEED( 4 )
109 COMPLEX X( * )
110* ..
111*
112* =====================================================================
113*
114* .. Parameters ..
115 REAL ZERO, ONE, TWO
116 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0 )
117 INTEGER LV
118 parameter( lv = 128 )
119 REAL TWOPI
120 parameter( twopi = 6.28318530717958647692528676655900576839e+0 )
121* ..
122* .. Local Scalars ..
123 INTEGER I, IL, IV
124* ..
125* .. Local Arrays ..
126 REAL U( LV )
127* ..
128* .. Intrinsic Functions ..
129 INTRINSIC cmplx, exp, log, min, sqrt
130* ..
131* .. External Subroutines ..
132 EXTERNAL slaruv
133* ..
134* .. Executable Statements ..
135*
136 DO 60 iv = 1, n, lv / 2
137 il = min( lv / 2, n-iv+1 )
138*
139* Call SLARUV to generate 2*IL real numbers from a uniform (0,1)
140* distribution (2*IL <= LV)
141*
142 CALL slaruv( iseed, 2*il, u )
143*
144 IF( idist.EQ.1 ) THEN
145*
146* Copy generated numbers
147*
148 DO 10 i = 1, il
149 x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ) )
150 10 CONTINUE
151 ELSE IF( idist.EQ.2 ) THEN
152*
153* Convert generated numbers to uniform (-1,1) distribution
154*
155 DO 20 i = 1, il
156 x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,
157 $ two*u( 2*i )-one )
158 20 CONTINUE
159 ELSE IF( idist.EQ.3 ) THEN
160*
161* Convert generated numbers to normal (0,1) distribution
162*
163 DO 30 i = 1, il
164 x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*
165 $ exp( cmplx( zero, twopi*u( 2*i ) ) )
166 30 CONTINUE
167 ELSE IF( idist.EQ.4 ) THEN
168*
169* Convert generated numbers to complex numbers uniformly
170* distributed on the unit disk
171*
172 DO 40 i = 1, il
173 x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*
174 $ exp( cmplx( zero, twopi*u( 2*i ) ) )
175 40 CONTINUE
176 ELSE IF( idist.EQ.5 ) THEN
177*
178* Convert generated numbers to complex numbers uniformly
179* distributed on the unit circle
180*
181 DO 50 i = 1, il
182 x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ) ) )
183 50 CONTINUE
184 END IF
185 60 CONTINUE
186 RETURN
187*
188* End of CLARNV
189*
slaruv
subroutine slaruv(iseed, n, x)
SLARUV returns a vector of n random real numbers from a uniform distribution.
Definition slaruv.f:95

◆ clarrv()

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

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

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

Purpose:
!>
!> CLARRV 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 SLARRE.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix.  N >= 0.
!>
[in]VL
!>          VL is REAL
!>          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 REAL
!>          Upper 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,out]D
!>          D is REAL 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 REAL 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 SLARRE.
!>          On exit, L is overwritten.
!>
[in]PIVMIN
!>          PIVMIN is REAL
!>          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 REAL
!>
[in]RTOL1
!>          RTOL1 is REAL
!>
[in]RTOL2
!>          RTOL2 is REAL
!>           Parameters for bisection.
!>           An interval [LEFT,RIGHT] has converged if
!>           RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
!>
[in,out]W
!>          W is REAL 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 SLARRE 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 REAL 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 REAL 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 REAL 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 COMPLEX 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 REAL 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 CLARRV.
!>          < 0:  One of the called subroutines signaled an internal problem.
!>                Needs inspection of the corresponding parameter IINFO
!>                for further information.
!>
!>          =-1:  Problem in SLARRB when refining a child's eigenvalues.
!>          =-2:  Problem in SLARRF 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 SLARRB 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 281 of file clarrv.f.

286*
287* -- LAPACK auxiliary routine --
288* -- LAPACK is a software package provided by Univ. of Tennessee, --
289* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
290*
291* .. Scalar Arguments ..
292 INTEGER DOL, DOU, INFO, LDZ, M, N
293 REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
294* ..
295* .. Array Arguments ..
296 INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
297 $ ISUPPZ( * ), IWORK( * )
298 REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
299 $ WGAP( * ), WORK( * )
300 COMPLEX Z( LDZ, * )
301* ..
302*
303* =====================================================================
304*
305* .. Parameters ..
306 INTEGER MAXITR
307 parameter( maxitr = 10 )
308 COMPLEX CZERO
309 parameter( czero = ( 0.0e0, 0.0e0 ) )
310 REAL ZERO, ONE, TWO, THREE, FOUR, HALF
311 parameter( zero = 0.0e0, one = 1.0e0,
312 $ two = 2.0e0, three = 3.0e0,
313 $ four = 4.0e0, half = 0.5e0)
314* ..
315* .. Local Scalars ..
316 LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
317 INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
318 $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
319 $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
320 $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
321 $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
322 $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
323 $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
324 $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
325 $ ZUSEDW
326 INTEGER INDIN1, INDIN2
327 REAL BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
328 $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
329 $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
330 $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
331* ..
332* .. External Functions ..
333 REAL SLAMCH
334 EXTERNAL slamch
335* ..
336* .. External Subroutines ..
337 EXTERNAL clar1v, claset, csscal, scopy, slarrb,
338 $ slarrf
339* ..
340* .. Intrinsic Functions ..
341 INTRINSIC abs, real, max, min
342 INTRINSIC cmplx
343* ..
344* .. Executable Statements ..
345* ..
346
347 info = 0
348*
349* Quick return if possible
350*
351 IF( (n.LE.0).OR.(m.LE.0) ) THEN
352 RETURN
353 END IF
354*
355* The first N entries of WORK are reserved for the eigenvalues
356 indld = n+1
357 indlld= 2*n+1
358 indin1 = 3*n + 1
359 indin2 = 4*n + 1
360 indwrk = 5*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 claset( 'Full', n, zusedw, czero, czero,
396 $ z(1,zusedl), ldz )
397
398 eps = slamch( '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 ) = cmplx( one, zero )
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 scopy( 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 DO 45 k = 1, in - 1
557 d( ibegin+k-1 ) = real( z( ibegin+k-1,
558 $ j ) )
559 l( ibegin+k-1 ) = real( z( ibegin+k-1,
560 $ j+1 ) )
561 45 CONTINUE
562 d( iend ) = real( z( iend, j ) )
563 sigma = real( z( iend, j+1 ) )
564
565* Set the corresponding entries in Z to zero
566 CALL claset( 'Full', in, 2, czero, czero,
567 $ z( ibegin, j), ldz )
568 END IF
569
570* Compute DL and DLL of current RRR
571 DO 50 j = ibegin, iend-1
572 tmp = d( j )*l( j )
573 work( indld-1+j ) = tmp
574 work( indlld-1+j ) = tmp*l( j )
575 50 CONTINUE
576
577 IF( ndepth.GT.0 ) THEN
578* P and Q are index of the first and last eigenvalue to compute
579* within the current block
580 p = indexw( wbegin-1+oldfst )
581 q = indexw( wbegin-1+oldlst )
582* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET
583* through the Q-OFFSET elements of these arrays are to be used.
584* OFFSET = P-OLDFST
585 offset = indexw( wbegin ) - 1
586* perform limited bisection (if necessary) to get approximate
587* eigenvalues to the precision needed.
588 CALL slarrb( in, d( ibegin ),
589 $ work(indlld+ibegin-1),
590 $ p, q, rtol1, rtol2, offset,
591 $ work(wbegin),wgap(wbegin),werr(wbegin),
592 $ work( indwrk ), iwork( iindwk ),
593 $ pivmin, spdiam, in, iinfo )
594 IF( iinfo.NE.0 ) THEN
595 info = -1
596 RETURN
597 ENDIF
598* We also recompute the extremal gaps. W holds all eigenvalues
599* of the unshifted matrix and must be used for computation
600* of WGAP, the entries of WORK might stem from RRRs with
601* different shifts. The gaps from WBEGIN-1+OLDFST to
602* WBEGIN-1+OLDLST are correctly computed in SLARRB.
603* However, we only allow the gaps to become greater since
604* this is what should happen when we decrease WERR
605 IF( oldfst.GT.1) THEN
606 wgap( wbegin+oldfst-2 ) =
607 $ max(wgap(wbegin+oldfst-2),
608 $ w(wbegin+oldfst-1)-werr(wbegin+oldfst-1)
609 $ - w(wbegin+oldfst-2)-werr(wbegin+oldfst-2) )
610 ENDIF
611 IF( wbegin + oldlst -1 .LT. wend ) THEN
612 wgap( wbegin+oldlst-1 ) =
613 $ max(wgap(wbegin+oldlst-1),
614 $ w(wbegin+oldlst)-werr(wbegin+oldlst)
615 $ - w(wbegin+oldlst-1)-werr(wbegin+oldlst-1) )
616 ENDIF
617* Each time the eigenvalues in WORK get refined, we store
618* the newly found approximation with all shifts applied in W
619 DO 53 j=oldfst,oldlst
620 w(wbegin+j-1) = work(wbegin+j-1)+sigma
621 53 CONTINUE
622 END IF
623
624* Process the current node.
625 newfst = oldfst
626 DO 140 j = oldfst, oldlst
627 IF( j.EQ.oldlst ) THEN
628* we are at the right end of the cluster, this is also the
629* boundary of the child cluster
630 newlst = j
631 ELSE IF ( wgap( wbegin + j -1).GE.
632 $ minrgp* abs( work(wbegin + j -1) ) ) THEN
633* the right relative gap is big enough, the child cluster
634* (NEWFST,..,NEWLST) is well separated from the following
635 newlst = j
636 ELSE
637* inside a child cluster, the relative gap is not
638* big enough.
639 GOTO 140
640 END IF
641
642* Compute size of child cluster found
643 newsiz = newlst - newfst + 1
644
645* NEWFTT is the place in Z where the new RRR or the computed
646* eigenvector is to be stored
647 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
648* Store representation at location of the leftmost evalue
649* of the cluster
650 newftt = wbegin + newfst - 1
651 ELSE
652 IF(wbegin+newfst-1.LT.dol) THEN
653* Store representation at the left end of Z array
654 newftt = dol - 1
655 ELSEIF(wbegin+newfst-1.GT.dou) THEN
656* Store representation at the right end of Z array
657 newftt = dou
658 ELSE
659 newftt = wbegin + newfst - 1
660 ENDIF
661 ENDIF
662
663 IF( newsiz.GT.1) THEN
664*
665* Current child is not a singleton but a cluster.
666* Compute and store new representation of child.
667*
668*
669* Compute left and right cluster gap.
670*
671* LGAP and RGAP are not computed from WORK because
672* the eigenvalue approximations may stem from RRRs
673* different shifts. However, W hold all eigenvalues
674* of the unshifted matrix. Still, the entries in WGAP
675* have to be computed from WORK since the entries
676* in W might be of the same order so that gaps are not
677* exhibited correctly for very close eigenvalues.
678 IF( newfst.EQ.1 ) THEN
679 lgap = max( zero,
680 $ w(wbegin)-werr(wbegin) - vl )
681 ELSE
682 lgap = wgap( wbegin+newfst-2 )
683 ENDIF
684 rgap = wgap( wbegin+newlst-1 )
685*
686* Compute left- and rightmost eigenvalue of child
687* to high precision in order to shift as close
688* as possible and obtain as large relative gaps
689* as possible
690*
691 DO 55 k =1,2
692 IF(k.EQ.1) THEN
693 p = indexw( wbegin-1+newfst )
694 ELSE
695 p = indexw( wbegin-1+newlst )
696 ENDIF
697 offset = indexw( wbegin ) - 1
698 CALL slarrb( in, d(ibegin),
699 $ work( indlld+ibegin-1 ),p,p,
700 $ rqtol, rqtol, offset,
701 $ work(wbegin),wgap(wbegin),
702 $ werr(wbegin),work( indwrk ),
703 $ iwork( iindwk ), pivmin, spdiam,
704 $ in, iinfo )
705 55 CONTINUE
706*
707 IF((wbegin+newlst-1.LT.dol).OR.
708 $ (wbegin+newfst-1.GT.dou)) THEN
709* if the cluster contains no desired eigenvalues
710* skip the computation of that branch of the rep. tree
711*
712* We could skip before the refinement of the extremal
713* eigenvalues of the child, but then the representation
714* tree could be different from the one when nothing is
715* skipped. For this reason we skip at this place.
716 idone = idone + newlst - newfst + 1
717 GOTO 139
718 ENDIF
719*
720* Compute RRR of child cluster.
721* Note that the new RRR is stored in Z
722*
723* SLARRF needs LWORK = 2*N
724 CALL slarrf( in, d( ibegin ), l( ibegin ),
725 $ work(indld+ibegin-1),
726 $ newfst, newlst, work(wbegin),
727 $ wgap(wbegin), werr(wbegin),
728 $ spdiam, lgap, rgap, pivmin, tau,
729 $ work( indin1 ), work( indin2 ),
730 $ work( indwrk ), iinfo )
731* In the complex case, SLARRF cannot write
732* the new RRR directly into Z and needs an intermediate
733* workspace
734 DO 56 k = 1, in-1
735 z( ibegin+k-1, newftt ) =
736 $ cmplx( work( indin1+k-1 ), zero )
737 z( ibegin+k-1, newftt+1 ) =
738 $ cmplx( work( indin2+k-1 ), zero )
739 56 CONTINUE
740 z( iend, newftt ) =
741 $ cmplx( work( indin1+in-1 ), zero )
742 IF( iinfo.EQ.0 ) THEN
743* a new RRR for the cluster was found by SLARRF
744* update shift and store it
745 ssigma = sigma + tau
746 z( iend, newftt+1 ) = cmplx( ssigma, zero )
747* WORK() are the midpoints and WERR() the semi-width
748* Note that the entries in W are unchanged.
749 DO 116 k = newfst, newlst
750 fudge =
751 $ three*eps*abs(work(wbegin+k-1))
752 work( wbegin + k - 1 ) =
753 $ work( wbegin + k - 1) - tau
754 fudge = fudge +
755 $ four*eps*abs(work(wbegin+k-1))
756* Fudge errors
757 werr( wbegin + k - 1 ) =
758 $ werr( wbegin + k - 1 ) + fudge
759* Gaps are not fudged. Provided that WERR is small
760* when eigenvalues are close, a zero gap indicates
761* that a new representation is needed for resolving
762* the cluster. A fudge could lead to a wrong decision
763* of judging eigenvalues 'separated' which in
764* reality are not. This could have a negative impact
765* on the orthogonality of the computed eigenvectors.
766 116 CONTINUE
767
768 nclus = nclus + 1
769 k = newcls + 2*nclus
770 iwork( k-1 ) = newfst
771 iwork( k ) = newlst
772 ELSE
773 info = -2
774 RETURN
775 ENDIF
776 ELSE
777*
778* Compute eigenvector of singleton
779*
780 iter = 0
781*
782 tol = four * log(real(in)) * eps
783*
784 k = newfst
785 windex = wbegin + k - 1
786 windmn = max(windex - 1,1)
787 windpl = min(windex + 1,m)
788 lambda = work( windex )
789 done = done + 1
790* Check if eigenvector computation is to be skipped
791 IF((windex.LT.dol).OR.
792 $ (windex.GT.dou)) THEN
793 eskip = .true.
794 GOTO 125
795 ELSE
796 eskip = .false.
797 ENDIF
798 left = work( windex ) - werr( windex )
799 right = work( windex ) + werr( windex )
800 indeig = indexw( windex )
801* Note that since we compute the eigenpairs for a child,
802* all eigenvalue approximations are w.r.t the same shift.
803* In this case, the entries in WORK should be used for
804* computing the gaps since they exhibit even very small
805* differences in the eigenvalues, as opposed to the
806* entries in W which might "look" the same.
807
808 IF( k .EQ. 1) THEN
809* In the case RANGE='I' and with not much initial
810* accuracy in LAMBDA and VL, the formula
811* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
812* can lead to an overestimation of the left gap and
813* thus to inadequately early RQI 'convergence'.
814* Prevent this by forcing a small left gap.
815 lgap = eps*max(abs(left),abs(right))
816 ELSE
817 lgap = wgap(windmn)
818 ENDIF
819 IF( k .EQ. im) THEN
820* In the case RANGE='I' and with not much initial
821* accuracy in LAMBDA and VU, the formula
822* can lead to an overestimation of the right gap and
823* thus to inadequately early RQI 'convergence'.
824* Prevent this by forcing a small right gap.
825 rgap = eps*max(abs(left),abs(right))
826 ELSE
827 rgap = wgap(windex)
828 ENDIF
829 gap = min( lgap, rgap )
830 IF(( k .EQ. 1).OR.(k .EQ. im)) THEN
831* The eigenvector support can become wrong
832* because significant entries could be cut off due to a
833* large GAPTOL parameter in LAR1V. Prevent this.
834 gaptol = zero
835 ELSE
836 gaptol = gap * eps
837 ENDIF
838 isupmn = in
839 isupmx = 1
840* Update WGAP so that it holds the minimum gap
841* to the left or the right. This is crucial in the
842* case where bisection is used to ensure that the
843* eigenvalue is refined up to the required precision.
844* The correct value is restored afterwards.
845 savgap = wgap(windex)
846 wgap(windex) = gap
847* We want to use the Rayleigh Quotient Correction
848* as often as possible since it converges quadratically
849* when we are close enough to the desired eigenvalue.
850* However, the Rayleigh Quotient can have the wrong sign
851* and lead us away from the desired eigenvalue. In this
852* case, the best we can do is to use bisection.
853 usedbs = .false.
854 usedrq = .false.
855* Bisection is initially turned off unless it is forced
856 needbs = .NOT.tryrqc
857 120 CONTINUE
858* Check if bisection should be used to refine eigenvalue
859 IF(needbs) THEN
860* Take the bisection as new iterate
861 usedbs = .true.
862 itmp1 = iwork( iindr+windex )
863 offset = indexw( wbegin ) - 1
864 CALL slarrb( in, d(ibegin),
865 $ work(indlld+ibegin-1),indeig,indeig,
866 $ zero, two*eps, offset,
867 $ work(wbegin),wgap(wbegin),
868 $ werr(wbegin),work( indwrk ),
869 $ iwork( iindwk ), pivmin, spdiam,
870 $ itmp1, iinfo )
871 IF( iinfo.NE.0 ) THEN
872 info = -3
873 RETURN
874 ENDIF
875 lambda = work( windex )
876* Reset twist index from inaccurate LAMBDA to
877* force computation of true MINGMA
878 iwork( iindr+windex ) = 0
879 ENDIF
880* Given LAMBDA, compute the eigenvector.
881 CALL clar1v( in, 1, in, lambda, d( ibegin ),
882 $ l( ibegin ), work(indld+ibegin-1),
883 $ work(indlld+ibegin-1),
884 $ pivmin, gaptol, z( ibegin, windex ),
885 $ .NOT.usedbs, negcnt, ztz, mingma,
886 $ iwork( iindr+windex ), isuppz( 2*windex-1 ),
887 $ nrminv, resid, rqcorr, work( indwrk ) )
888 IF(iter .EQ. 0) THEN
889 bstres = resid
890 bstw = lambda
891 ELSEIF(resid.LT.bstres) THEN
892 bstres = resid
893 bstw = lambda
894 ENDIF
895 isupmn = min(isupmn,isuppz( 2*windex-1 ))
896 isupmx = max(isupmx,isuppz( 2*windex ))
897 iter = iter + 1
898
899* sin alpha <= |resid|/gap
900* Note that both the residual and the gap are
901* proportional to the matrix, so ||T|| doesn't play
902* a role in the quotient
903
904*
905* Convergence test for Rayleigh-Quotient iteration
906* (omitted when Bisection has been used)
907*
908 IF( resid.GT.tol*gap .AND. abs( rqcorr ).GT.
909 $ rqtol*abs( lambda ) .AND. .NOT. usedbs)
910 $ THEN
911* We need to check that the RQCORR update doesn't
912* move the eigenvalue away from the desired one and
913* towards a neighbor. -> protection with bisection
914 IF(indeig.LE.negcnt) THEN
915* The wanted eigenvalue lies to the left
916 sgndef = -one
917 ELSE
918* The wanted eigenvalue lies to the right
919 sgndef = one
920 ENDIF
921* We only use the RQCORR if it improves the
922* the iterate reasonably.
923 IF( ( rqcorr*sgndef.GE.zero )
924 $ .AND.( lambda + rqcorr.LE. right)
925 $ .AND.( lambda + rqcorr.GE. left)
926 $ ) THEN
927 usedrq = .true.
928* Store new midpoint of bisection interval in WORK
929 IF(sgndef.EQ.one) THEN
930* The current LAMBDA is on the left of the true
931* eigenvalue
932 left = lambda
933* We prefer to assume that the error estimate
934* is correct. We could make the interval not
935* as a bracket but to be modified if the RQCORR
936* chooses to. In this case, the RIGHT side should
937* be modified as follows:
938* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
939 ELSE
940* The current LAMBDA is on the right of the true
941* eigenvalue
942 right = lambda
943* See comment about assuming the error estimate is
944* correct above.
945* LEFT = MIN(LEFT, LAMBDA + RQCORR)
946 ENDIF
947 work( windex ) =
948 $ half * (right + left)
949* Take RQCORR since it has the correct sign and
950* improves the iterate reasonably
951 lambda = lambda + rqcorr
952* Update width of error interval
953 werr( windex ) =
954 $ half * (right-left)
955 ELSE
956 needbs = .true.
957 ENDIF
958 IF(right-left.LT.rqtol*abs(lambda)) THEN
959* The eigenvalue is computed to bisection accuracy
960* compute eigenvector and stop
961 usedbs = .true.
962 GOTO 120
963 ELSEIF( iter.LT.maxitr ) THEN
964 GOTO 120
965 ELSEIF( iter.EQ.maxitr ) THEN
966 needbs = .true.
967 GOTO 120
968 ELSE
969 info = 5
970 RETURN
971 END IF
972 ELSE
973 stp2ii = .false.
974 IF(usedrq .AND. usedbs .AND.
975 $ bstres.LE.resid) THEN
976 lambda = bstw
977 stp2ii = .true.
978 ENDIF
979 IF (stp2ii) THEN
980* improve error angle by second step
981 CALL clar1v( in, 1, in, lambda,
982 $ d( ibegin ), l( ibegin ),
983 $ work(indld+ibegin-1),
984 $ work(indlld+ibegin-1),
985 $ pivmin, gaptol, z( ibegin, windex ),
986 $ .NOT.usedbs, negcnt, ztz, mingma,
987 $ iwork( iindr+windex ),
988 $ isuppz( 2*windex-1 ),
989 $ nrminv, resid, rqcorr, work( indwrk ) )
990 ENDIF
991 work( windex ) = lambda
992 END IF
993*
994* Compute FP-vector support w.r.t. whole matrix
995*
996 isuppz( 2*windex-1 ) = isuppz( 2*windex-1 )+oldien
997 isuppz( 2*windex ) = isuppz( 2*windex )+oldien
998 zfrom = isuppz( 2*windex-1 )
999 zto = isuppz( 2*windex )
1000 isupmn = isupmn + oldien
1001 isupmx = isupmx + oldien
1002* Ensure vector is ok if support in the RQI has changed
1003 IF(isupmn.LT.zfrom) THEN
1004 DO 122 ii = isupmn,zfrom-1
1005 z( ii, windex ) = zero
1006 122 CONTINUE
1007 ENDIF
1008 IF(isupmx.GT.zto) THEN
1009 DO 123 ii = zto+1,isupmx
1010 z( ii, windex ) = zero
1011 123 CONTINUE
1012 ENDIF
1013 CALL csscal( zto-zfrom+1, nrminv,
1014 $ z( zfrom, windex ), 1 )
1015 125 CONTINUE
1016* Update W
1017 w( windex ) = lambda+sigma
1018* Recompute the gaps on the left and right
1019* But only allow them to become larger and not
1020* smaller (which can only happen through "bad"
1021* cancellation and doesn't reflect the theory
1022* where the initial gaps are underestimated due
1023* to WERR being too crude.)
1024 IF(.NOT.eskip) THEN
1025 IF( k.GT.1) THEN
1026 wgap( windmn ) = max( wgap(windmn),
1027 $ w(windex)-werr(windex)
1028 $ - w(windmn)-werr(windmn) )
1029 ENDIF
1030 IF( windex.LT.wend ) THEN
1031 wgap( windex ) = max( savgap,
1032 $ w( windpl )-werr( windpl )
1033 $ - w( windex )-werr( windex) )
1034 ENDIF
1035 ENDIF
1036 idone = idone + 1
1037 ENDIF
1038* here ends the code for the current child
1039*
1040 139 CONTINUE
1041* Proceed to any remaining child nodes
1042 newfst = j + 1
1043 140 CONTINUE
1044 150 CONTINUE
1045 ndepth = ndepth + 1
1046 GO TO 40
1047 END IF
1048 ibegin = iend + 1
1049 wbegin = wend + 1
1050 170 CONTINUE
1051*
1052
1053 RETURN
1054*
1055* End of CLARRV
1056*
slarrb
subroutine slarrb(n, d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, work, iwork, pivmin, spdiam, twist, info)
SLARRB provides limited bisection to locate eigenvalues for more accuracy.
Definition slarrb.f:196
slarrf
subroutine slarrf(n, d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, sigma, dplus, lplus, work, info)
SLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
Definition slarrf.f:193
clar1v
subroutine clar1v(n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
CLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...
Definition clar1v.f:230
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82

◆ clartv()

subroutine clartv ( integer n,
complex, dimension( * ) x,
integer incx,
complex, dimension( * ) y,
integer incy,
real, dimension( * ) c,
complex, dimension( * ) s,
integer incc )

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

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

Purpose:
!>
!> CLARTV applies a vector of complex plane rotations with real cosines
!> to elements of the complex vectors x and y. For i = 1,2,...,n
!>
!>    ( x(i) ) := (        c(i)   s(i) ) ( x(i) )
!>    ( y(i) )    ( -conjg(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 COMPLEX 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 COMPLEX 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 REAL array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is COMPLEX 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 106 of file clartv.f.

107*
108* -- LAPACK auxiliary routine --
109* -- LAPACK is a software package provided by Univ. of Tennessee, --
110* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
111*
112* .. Scalar Arguments ..
113 INTEGER INCC, INCX, INCY, N
114* ..
115* .. Array Arguments ..
116 REAL C( * )
117 COMPLEX S( * ), X( * ), Y( * )
118* ..
119*
120* =====================================================================
121*
122* .. Local Scalars ..
123 INTEGER I, IC, IX, IY
124 COMPLEX XI, YI
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC conjg
128* ..
129* .. Executable Statements ..
130*
131 ix = 1
132 iy = 1
133 ic = 1
134 DO 10 i = 1, n
135 xi = x( ix )
136 yi = y( iy )
137 x( ix ) = c( ic )*xi + s( ic )*yi
138 y( iy ) = c( ic )*yi - conjg( s( ic ) )*xi
139 ix = ix + incx
140 iy = iy + incy
141 ic = ic + incc
142 10 CONTINUE
143 RETURN
144*
145* End of CLARTV
146*

◆ clascl()

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

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

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

Purpose:
!>
!> CLASCL multiplies the M by N complex matrix A by the real scalar
!> CTO/CFROM.  This is done without over/underflow as long as the final
!> result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
!> A may be full, upper triangular, lower triangular, upper Hessenberg,
!> or banded.
!>
Parameters
[in]TYPE
!>          TYPE is CHARACTER*1
!>          TYPE indices the storage type of the input matrix.
!>          = 'G':  A is a full matrix.
!>          = 'L':  A is a lower triangular matrix.
!>          = 'U':  A is an upper triangular matrix.
!>          = 'H':  A is an upper Hessenberg matrix.
!>          = 'B':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the lower
!>                  half stored.
!>          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
!>                  and upper bandwidth KU and with the only the upper
!>                  half stored.
!>          = 'Z':  A is a band matrix with lower bandwidth KL and upper
!>                  bandwidth KU. See CGBTRF for storage details.
!>
[in]KL
!>          KL is INTEGER
!>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]KU
!>          KU is INTEGER
!>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]CFROM
!>          CFROM is REAL
!>
[in]CTO
!>          CTO is REAL
!>
!>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
!>          without over/underflow if the final result CTO*A(I,J)/CFROM
!>          can be represented without over/underflow.  CFROM must be
!>          nonzero.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
!>          storage type.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If TYPE = 'G', 'L', 'U', 'H', LDA >= max(1,M);
!>             TYPE = 'B', LDA >= KL+1;
!>             TYPE = 'Q', LDA >= KU+1;
!>             TYPE = 'Z', LDA >= 2*KL+KU+1.
!>
[out]INFO
!>          INFO is INTEGER
!>          0  - successful exit
!>          <0 - if INFO = -i, the i-th argument had an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file clascl.f.

143*
144* -- LAPACK auxiliary routine --
145* -- LAPACK is a software package provided by Univ. of Tennessee, --
146* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
147*
148* .. Scalar Arguments ..
149 CHARACTER TYPE
150 INTEGER INFO, KL, KU, LDA, M, N
151 REAL CFROM, CTO
152* ..
153* .. Array Arguments ..
154 COMPLEX A( LDA, * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 REAL ZERO, ONE
161 parameter( zero = 0.0e0, one = 1.0e0 )
162* ..
163* .. Local Scalars ..
164 LOGICAL DONE
165 INTEGER I, ITYPE, J, K1, K2, K3, K4
166 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
167* ..
168* .. External Functions ..
169 LOGICAL LSAME, SISNAN
170 REAL SLAMCH
171 EXTERNAL lsame, slamch, sisnan
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC abs, max, min
175* ..
176* .. External Subroutines ..
177 EXTERNAL xerbla
178* ..
179* .. Executable Statements ..
180*
181* Test the input arguments
182*
183 info = 0
184*
185 IF( lsame( TYPE, 'G' ) ) THEN
186 itype = 0
187 ELSE IF( lsame( TYPE, 'L' ) ) THEN
188 itype = 1
189 ELSE IF( lsame( TYPE, 'U' ) ) THEN
190 itype = 2
191 ELSE IF( lsame( TYPE, 'H' ) ) THEN
192 itype = 3
193 ELSE IF( lsame( TYPE, 'B' ) ) THEN
194 itype = 4
195 ELSE IF( lsame( TYPE, 'Q' ) ) THEN
196 itype = 5
197 ELSE IF( lsame( TYPE, 'Z' ) ) THEN
198 itype = 6
199 ELSE
200 itype = -1
201 END IF
202*
203 IF( itype.EQ.-1 ) THEN
204 info = -1
205 ELSE IF( cfrom.EQ.zero .OR. sisnan(cfrom) ) THEN
206 info = -4
207 ELSE IF( sisnan(cto) ) THEN
208 info = -5
209 ELSE IF( m.LT.0 ) THEN
210 info = -6
211 ELSE IF( n.LT.0 .OR. ( itype.EQ.4 .AND. n.NE.m ) .OR.
212 $ ( itype.EQ.5 .AND. n.NE.m ) ) THEN
213 info = -7
214 ELSE IF( itype.LE.3 .AND. lda.LT.max( 1, m ) ) THEN
215 info = -9
216 ELSE IF( itype.GE.4 ) THEN
217 IF( kl.LT.0 .OR. kl.GT.max( m-1, 0 ) ) THEN
218 info = -2
219 ELSE IF( ku.LT.0 .OR. ku.GT.max( n-1, 0 ) .OR.
220 $ ( ( itype.EQ.4 .OR. itype.EQ.5 ) .AND. kl.NE.ku ) )
221 $ THEN
222 info = -3
223 ELSE IF( ( itype.EQ.4 .AND. lda.LT.kl+1 ) .OR.
224 $ ( itype.EQ.5 .AND. lda.LT.ku+1 ) .OR.
225 $ ( itype.EQ.6 .AND. lda.LT.2*kl+ku+1 ) ) THEN
226 info = -9
227 END IF
228 END IF
229*
230 IF( info.NE.0 ) THEN
231 CALL xerbla( 'CLASCL', -info )
232 RETURN
233 END IF
234*
235* Quick return if possible
236*
237 IF( n.EQ.0 .OR. m.EQ.0 )
238 $ RETURN
239*
240* Get machine parameters
241*
242 smlnum = slamch( 'S' )
243 bignum = one / smlnum
244*
245 cfromc = cfrom
246 ctoc = cto
247*
248 10 CONTINUE
249 cfrom1 = cfromc*smlnum
250 IF( cfrom1.EQ.cfromc ) THEN
251! CFROMC is an inf. Multiply by a correctly signed zero for
252! finite CTOC, or a NaN if CTOC is infinite.
253 mul = ctoc / cfromc
254 done = .true.
255 cto1 = ctoc
256 ELSE
257 cto1 = ctoc / bignum
258 IF( cto1.EQ.ctoc ) THEN
259! CTOC is either 0 or an inf. In both cases, CTOC itself
260! serves as the correct multiplication factor.
261 mul = ctoc
262 done = .true.
263 cfromc = one
264 ELSE IF( abs( cfrom1 ).GT.abs( ctoc ) .AND. ctoc.NE.zero ) THEN
265 mul = smlnum
266 done = .false.
267 cfromc = cfrom1
268 ELSE IF( abs( cto1 ).GT.abs( cfromc ) ) THEN
269 mul = bignum
270 done = .false.
271 ctoc = cto1
272 ELSE
273 mul = ctoc / cfromc
274 done = .true.
275 END IF
276 END IF
277*
278 IF( itype.EQ.0 ) THEN
279*
280* Full matrix
281*
282 DO 30 j = 1, n
283 DO 20 i = 1, m
284 a( i, j ) = a( i, j )*mul
285 20 CONTINUE
286 30 CONTINUE
287*
288 ELSE IF( itype.EQ.1 ) THEN
289*
290* Lower triangular matrix
291*
292 DO 50 j = 1, n
293 DO 40 i = j, m
294 a( i, j ) = a( i, j )*mul
295 40 CONTINUE
296 50 CONTINUE
297*
298 ELSE IF( itype.EQ.2 ) THEN
299*
300* Upper triangular matrix
301*
302 DO 70 j = 1, n
303 DO 60 i = 1, min( j, m )
304 a( i, j ) = a( i, j )*mul
305 60 CONTINUE
306 70 CONTINUE
307*
308 ELSE IF( itype.EQ.3 ) THEN
309*
310* Upper Hessenberg matrix
311*
312 DO 90 j = 1, n
313 DO 80 i = 1, min( j+1, m )
314 a( i, j ) = a( i, j )*mul
315 80 CONTINUE
316 90 CONTINUE
317*
318 ELSE IF( itype.EQ.4 ) THEN
319*
320* Lower half of a symmetric band matrix
321*
322 k3 = kl + 1
323 k4 = n + 1
324 DO 110 j = 1, n
325 DO 100 i = 1, min( k3, k4-j )
326 a( i, j ) = a( i, j )*mul
327 100 CONTINUE
328 110 CONTINUE
329*
330 ELSE IF( itype.EQ.5 ) THEN
331*
332* Upper half of a symmetric band matrix
333*
334 k1 = ku + 2
335 k3 = ku + 1
336 DO 130 j = 1, n
337 DO 120 i = max( k1-j, 1 ), k3
338 a( i, j ) = a( i, j )*mul
339 120 CONTINUE
340 130 CONTINUE
341*
342 ELSE IF( itype.EQ.6 ) THEN
343*
344* Band matrix
345*
346 k1 = kl + ku + 2
347 k2 = kl + 1
348 k3 = 2*kl + ku + 1
349 k4 = kl + ku + 1 + m
350 DO 150 j = 1, n
351 DO 140 i = max( k1-j, k2 ), min( k3, k4-j )
352 a( i, j ) = a( i, j )*mul
353 140 CONTINUE
354 150 CONTINUE
355*
356 END IF
357*
358 IF( .NOT.done )
359 $ GO TO 10
360*
361 RETURN
362*
363* End of CLASCL
364*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ claset()

subroutine claset ( character uplo,
integer m,
integer n,
complex alpha,
complex beta,
complex, dimension( lda, * ) a,
integer lda )

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

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

Purpose:
!>
!> CLASET initializes a 2-D array A to BETA on the diagonal and
!> ALPHA on the offdiagonals.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies the part of the matrix A to be set.
!>          = 'U':      Upper triangular part is set. The lower triangle
!>                      is unchanged.
!>          = 'L':      Lower triangular part is set. The upper triangle
!>                      is unchanged.
!>          Otherwise:  All of the matrix A is set.
!>
[in]M
!>          M is INTEGER
!>          On entry, M specifies the number of rows of A.
!>
[in]N
!>          N is INTEGER
!>          On entry, N specifies the number of columns of A.
!>
[in]ALPHA
!>          ALPHA is COMPLEX
!>          All the offdiagonal array elements are set to ALPHA.
!>
[in]BETA
!>          BETA is COMPLEX
!>          All the diagonal array elements are set to BETA.
!>
[out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          On entry, the m by n matrix A.
!>          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
!>                   A(i,i) = BETA , 1 <= i <= min(m,n)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file claset.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 UPLO
113 INTEGER LDA, M, N
114 COMPLEX ALPHA, BETA
115* ..
116* .. Array Arguments ..
117 COMPLEX A( LDA, * )
118* ..
119*
120* =====================================================================
121*
122* .. Local Scalars ..
123 INTEGER I, J
124* ..
125* .. External Functions ..
126 LOGICAL LSAME
127 EXTERNAL lsame
128* ..
129* .. Intrinsic Functions ..
130 INTRINSIC min
131* ..
132* .. Executable Statements ..
133*
134 IF( lsame( uplo, 'U' ) ) THEN
135*
136* Set the diagonal to BETA and the strictly upper triangular
137* part of the array to ALPHA.
138*
139 DO 20 j = 2, n
140 DO 10 i = 1, min( j-1, m )
141 a( i, j ) = alpha
142 10 CONTINUE
143 20 CONTINUE
144 DO 30 i = 1, min( n, m )
145 a( i, i ) = beta
146 30 CONTINUE
147*
148 ELSE IF( lsame( uplo, 'L' ) ) THEN
149*
150* Set the diagonal to BETA and the strictly lower triangular
151* part of the array to ALPHA.
152*
153 DO 50 j = 1, min( m, n )
154 DO 40 i = j + 1, m
155 a( i, j ) = alpha
156 40 CONTINUE
157 50 CONTINUE
158 DO 60 i = 1, min( n, m )
159 a( i, i ) = beta
160 60 CONTINUE
161*
162 ELSE
163*
164* Set the array to BETA on the diagonal and ALPHA on the
165* offdiagonal.
166*
167 DO 80 j = 1, n
168 DO 70 i = 1, m
169 a( i, j ) = alpha
170 70 CONTINUE
171 80 CONTINUE
172 DO 90 i = 1, min( m, n )
173 a( i, i ) = beta
174 90 CONTINUE
175 END IF
176*
177 RETURN
178*
179* End of CLASET
180*

◆ clasr()

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

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

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

Purpose:
!>
!> CLASR applies a sequence of real plane rotations to a complex matrix
!> A, from either the left or the right.
!>
!> When SIDE = 'L', the transformation takes the form
!>
!>    A := P*A
!>
!> and when SIDE = 'R', the transformation takes the form
!>
!>    A := A*P**T
!>
!> where P is an orthogonal matrix consisting of a sequence of z plane
!> rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
!> and P**T is the transpose of P.
!>
!> When DIRECT = 'F' (Forward sequence), then
!>
!>    P = P(z-1) * ... * P(2) * P(1)
!>
!> and when DIRECT = 'B' (Backward sequence), then
!>
!>    P = P(1) * P(2) * ... * P(z-1)
!>
!> where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
!>
!>    R(k) = (  c(k)  s(k) )
!>         = ( -s(k)  c(k) ).
!>
!> When PIVOT = 'V' (Variable pivot), the rotation is performed
!> for the plane (k,k+1), i.e., P(k) has the form
!>
!>    P(k) = (  1                                            )
!>           (       ...                                     )
!>           (              1                                )
!>           (                   c(k)  s(k)                  )
!>           (                  -s(k)  c(k)                  )
!>           (                                1              )
!>           (                                     ...       )
!>           (                                            1  )
!>
!> where R(k) appears as a rank-2 modification to the identity matrix in
!> rows and columns k and k+1.
!>
!> When PIVOT = 'T' (Top pivot), the rotation is performed for the
!> plane (1,k+1), so P(k) has the form
!>
!>    P(k) = (  c(k)                    s(k)                 )
!>           (         1                                     )
!>           (              ...                              )
!>           (                     1                         )
!>           ( -s(k)                    c(k)                 )
!>           (                                 1             )
!>           (                                      ...      )
!>           (                                             1 )
!>
!> where R(k) appears in rows and columns 1 and k+1.
!>
!> Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
!> performed for the plane (k,z), giving P(k) the form
!>
!>    P(k) = ( 1                                             )
!>           (      ...                                      )
!>           (             1                                 )
!>           (                  c(k)                    s(k) )
!>           (                         1                     )
!>           (                              ...              )
!>           (                                     1         )
!>           (                 -s(k)                    c(k) )
!>
!> where R(k) appears in rows and columns k and z.  The rotations are
!> performed without ever forming P(k) explicitly.
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>          Specifies whether the plane rotation matrix P is applied to
!>          A on the left or the right.
!>          = 'L':  Left, compute A := P*A
!>          = 'R':  Right, compute A:= A*P**T
!>
[in]PIVOT
!>          PIVOT is CHARACTER*1
!>          Specifies the plane for which P(k) is a plane rotation
!>          matrix.
!>          = 'V':  Variable pivot, the plane (k,k+1)
!>          = 'T':  Top pivot, the plane (1,k+1)
!>          = 'B':  Bottom pivot, the plane (k,z)
!>
[in]DIRECT
!>          DIRECT is CHARACTER*1
!>          Specifies whether P is a forward or backward sequence of
!>          plane rotations.
!>          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)
!>          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  If m <= 1, an immediate
!>          return is effected.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  If n <= 1, an
!>          immediate return is effected.
!>
[in]C
!>          C is REAL array, dimension
!>                  (M-1) if SIDE = 'L'
!>                  (N-1) if SIDE = 'R'
!>          The cosines c(k) of the plane rotations.
!>
[in]S
!>          S is REAL array, dimension
!>                  (M-1) if SIDE = 'L'
!>                  (N-1) if SIDE = 'R'
!>          The sines s(k) of the plane rotations.  The 2-by-2 plane
!>          rotation part of the matrix P(k), R(k), has the form
!>          R(k) = (  c(k)  s(k) )
!>                 ( -s(k)  c(k) ).
!>
[in,out]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The M-by-N matrix A.  On exit, A is overwritten by P*A if
!>          SIDE = 'R' or by A*P**T if SIDE = 'L'.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 199 of file clasr.f.

200*
201* -- LAPACK auxiliary routine --
202* -- LAPACK is a software package provided by Univ. of Tennessee, --
203* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
204*
205* .. Scalar Arguments ..
206 CHARACTER DIRECT, PIVOT, SIDE
207 INTEGER LDA, M, N
208* ..
209* .. Array Arguments ..
210 REAL C( * ), S( * )
211 COMPLEX A( LDA, * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 REAL ONE, ZERO
218 parameter( one = 1.0e+0, zero = 0.0e+0 )
219* ..
220* .. Local Scalars ..
221 INTEGER I, INFO, J
222 REAL CTEMP, STEMP
223 COMPLEX TEMP
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max
227* ..
228* .. External Functions ..
229 LOGICAL LSAME
230 EXTERNAL lsame
231* ..
232* .. External Subroutines ..
233 EXTERNAL xerbla
234* ..
235* .. Executable Statements ..
236*
237* Test the input parameters
238*
239 info = 0
240 IF( .NOT.( lsame( side, 'L' ) .OR. lsame( side, 'R' ) ) ) THEN
241 info = 1
242 ELSE IF( .NOT.( lsame( pivot, 'V' ) .OR. lsame( pivot,
243 $ 'T' ) .OR. lsame( pivot, 'B' ) ) ) THEN
244 info = 2
245 ELSE IF( .NOT.( lsame( direct, 'F' ) .OR. lsame( direct, 'B' ) ) )
246 $ THEN
247 info = 3
248 ELSE IF( m.LT.0 ) THEN
249 info = 4
250 ELSE IF( n.LT.0 ) THEN
251 info = 5
252 ELSE IF( lda.LT.max( 1, m ) ) THEN
253 info = 9
254 END IF
255 IF( info.NE.0 ) THEN
256 CALL xerbla( 'CLASR ', info )
257 RETURN
258 END IF
259*
260* Quick return if possible
261*
262 IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
263 $ RETURN
264 IF( lsame( side, 'L' ) ) THEN
265*
266* Form P * A
267*
268 IF( lsame( pivot, 'V' ) ) THEN
269 IF( lsame( direct, 'F' ) ) THEN
270 DO 20 j = 1, m - 1
271 ctemp = c( j )
272 stemp = s( j )
273 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
274 DO 10 i = 1, n
275 temp = a( j+1, i )
276 a( j+1, i ) = ctemp*temp - stemp*a( j, i )
277 a( j, i ) = stemp*temp + ctemp*a( j, i )
278 10 CONTINUE
279 END IF
280 20 CONTINUE
281 ELSE IF( lsame( direct, 'B' ) ) THEN
282 DO 40 j = m - 1, 1, -1
283 ctemp = c( j )
284 stemp = s( j )
285 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
286 DO 30 i = 1, n
287 temp = a( j+1, i )
288 a( j+1, i ) = ctemp*temp - stemp*a( j, i )
289 a( j, i ) = stemp*temp + ctemp*a( j, i )
290 30 CONTINUE
291 END IF
292 40 CONTINUE
293 END IF
294 ELSE IF( lsame( pivot, 'T' ) ) THEN
295 IF( lsame( direct, 'F' ) ) THEN
296 DO 60 j = 2, m
297 ctemp = c( j-1 )
298 stemp = s( j-1 )
299 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
300 DO 50 i = 1, n
301 temp = a( j, i )
302 a( j, i ) = ctemp*temp - stemp*a( 1, i )
303 a( 1, i ) = stemp*temp + ctemp*a( 1, i )
304 50 CONTINUE
305 END IF
306 60 CONTINUE
307 ELSE IF( lsame( direct, 'B' ) ) THEN
308 DO 80 j = m, 2, -1
309 ctemp = c( j-1 )
310 stemp = s( j-1 )
311 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
312 DO 70 i = 1, n
313 temp = a( j, i )
314 a( j, i ) = ctemp*temp - stemp*a( 1, i )
315 a( 1, i ) = stemp*temp + ctemp*a( 1, i )
316 70 CONTINUE
317 END IF
318 80 CONTINUE
319 END IF
320 ELSE IF( lsame( pivot, 'B' ) ) THEN
321 IF( lsame( direct, 'F' ) ) THEN
322 DO 100 j = 1, m - 1
323 ctemp = c( j )
324 stemp = s( j )
325 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
326 DO 90 i = 1, n
327 temp = a( j, i )
328 a( j, i ) = stemp*a( m, i ) + ctemp*temp
329 a( m, i ) = ctemp*a( m, i ) - stemp*temp
330 90 CONTINUE
331 END IF
332 100 CONTINUE
333 ELSE IF( lsame( direct, 'B' ) ) THEN
334 DO 120 j = m - 1, 1, -1
335 ctemp = c( j )
336 stemp = s( j )
337 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
338 DO 110 i = 1, n
339 temp = a( j, i )
340 a( j, i ) = stemp*a( m, i ) + ctemp*temp
341 a( m, i ) = ctemp*a( m, i ) - stemp*temp
342 110 CONTINUE
343 END IF
344 120 CONTINUE
345 END IF
346 END IF
347 ELSE IF( lsame( side, 'R' ) ) THEN
348*
349* Form A * P**T
350*
351 IF( lsame( pivot, 'V' ) ) THEN
352 IF( lsame( direct, 'F' ) ) THEN
353 DO 140 j = 1, n - 1
354 ctemp = c( j )
355 stemp = s( j )
356 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
357 DO 130 i = 1, m
358 temp = a( i, j+1 )
359 a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
360 a( i, j ) = stemp*temp + ctemp*a( i, j )
361 130 CONTINUE
362 END IF
363 140 CONTINUE
364 ELSE IF( lsame( direct, 'B' ) ) THEN
365 DO 160 j = n - 1, 1, -1
366 ctemp = c( j )
367 stemp = s( j )
368 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
369 DO 150 i = 1, m
370 temp = a( i, j+1 )
371 a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
372 a( i, j ) = stemp*temp + ctemp*a( i, j )
373 150 CONTINUE
374 END IF
375 160 CONTINUE
376 END IF
377 ELSE IF( lsame( pivot, 'T' ) ) THEN
378 IF( lsame( direct, 'F' ) ) THEN
379 DO 180 j = 2, n
380 ctemp = c( j-1 )
381 stemp = s( j-1 )
382 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
383 DO 170 i = 1, m
384 temp = a( i, j )
385 a( i, j ) = ctemp*temp - stemp*a( i, 1 )
386 a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
387 170 CONTINUE
388 END IF
389 180 CONTINUE
390 ELSE IF( lsame( direct, 'B' ) ) THEN
391 DO 200 j = n, 2, -1
392 ctemp = c( j-1 )
393 stemp = s( j-1 )
394 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
395 DO 190 i = 1, m
396 temp = a( i, j )
397 a( i, j ) = ctemp*temp - stemp*a( i, 1 )
398 a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
399 190 CONTINUE
400 END IF
401 200 CONTINUE
402 END IF
403 ELSE IF( lsame( pivot, 'B' ) ) THEN
404 IF( lsame( direct, 'F' ) ) THEN
405 DO 220 j = 1, n - 1
406 ctemp = c( j )
407 stemp = s( j )
408 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
409 DO 210 i = 1, m
410 temp = a( i, j )
411 a( i, j ) = stemp*a( i, n ) + ctemp*temp
412 a( i, n ) = ctemp*a( i, n ) - stemp*temp
413 210 CONTINUE
414 END IF
415 220 CONTINUE
416 ELSE IF( lsame( direct, 'B' ) ) THEN
417 DO 240 j = n - 1, 1, -1
418 ctemp = c( j )
419 stemp = s( j )
420 IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
421 DO 230 i = 1, m
422 temp = a( i, j )
423 a( i, j ) = stemp*a( i, n ) + ctemp*temp
424 a( i, n ) = ctemp*a( i, n ) - stemp*temp
425 230 CONTINUE
426 END IF
427 240 CONTINUE
428 END IF
429 END IF
430 END IF
431*
432 RETURN
433*
434* End of CLASR
435*

◆ claswp()

subroutine claswp ( integer n,
complex, dimension( lda, * ) a,
integer lda,
integer k1,
integer k2,
integer, dimension( * ) ipiv,
integer incx )

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

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

Purpose:
!>
!> CLASWP 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 COMPLEX 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 claswp.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 COMPLEX A( LDA, * )
126* ..
127*
128* =====================================================================
129*
130* .. Local Scalars ..
131 INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
132 COMPLEX 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 CLASWP
189*

◆ clatbs()

subroutine clatbs ( character uplo,
character trans,
character diag,
character normin,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
complex, dimension( * ) x,
real scale,
real, dimension( * ) cnorm,
integer info )

CLATBS solves a triangular banded system of equations.

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

Purpose:
!>
!> CLATBS solves one of the triangular systems
!>
!>    A * x = s*b,  A**T * x = s*b,  or  A**H * 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 CTBSV 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**H * x = s*b  (Conjugate 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 COMPLEX 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 COMPLEX 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 REAL
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  A**T * x = s*b,  or  A**H * 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 REAL 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, CTBSV
!>  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 CTBSV 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  or
!>  A**H *x = b.  The basic algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]' * 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 CTBSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 241 of file clatbs.f.

243*
244* -- LAPACK auxiliary routine --
245* -- LAPACK is a software package provided by Univ. of Tennessee, --
246* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
247*
248* .. Scalar Arguments ..
249 CHARACTER DIAG, NORMIN, TRANS, UPLO
250 INTEGER INFO, KD, LDAB, N
251 REAL SCALE
252* ..
253* .. Array Arguments ..
254 REAL CNORM( * )
255 COMPLEX AB( LDAB, * ), X( * )
256* ..
257*
258* =====================================================================
259*
260* .. Parameters ..
261 REAL ZERO, HALF, ONE, TWO
262 parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0,
263 $ two = 2.0e+0 )
264* ..
265* .. Local Scalars ..
266 LOGICAL NOTRAN, NOUNIT, UPPER
267 INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
268 REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
269 $ XBND, XJ, XMAX
270 COMPLEX CSUMJ, TJJS, USCAL, ZDUM
271* ..
272* .. External Functions ..
273 LOGICAL LSAME
274 INTEGER ICAMAX, ISAMAX
275 REAL SCASUM, SLAMCH
276 COMPLEX CDOTC, CDOTU, CLADIV
277 EXTERNAL lsame, icamax, isamax, scasum, slamch, cdotc,
278 $ cdotu, cladiv
279* ..
280* .. External Subroutines ..
281 EXTERNAL caxpy, csscal, ctbsv, slabad, sscal, xerbla
282* ..
283* .. Intrinsic Functions ..
284 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
285* ..
286* .. Statement Functions ..
287 REAL CABS1, CABS2
288* ..
289* .. Statement Function definitions ..
290 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
291 cabs2( zdum ) = abs( real( zdum ) / 2. ) +
292 $ abs( aimag( zdum ) / 2. )
293* ..
294* .. Executable Statements ..
295*
296 info = 0
297 upper = lsame( uplo, 'U' )
298 notran = lsame( trans, 'N' )
299 nounit = lsame( diag, 'N' )
300*
301* Test the input parameters.
302*
303 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
304 info = -1
305 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
306 $ lsame( trans, 'C' ) ) THEN
307 info = -2
308 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
309 info = -3
310 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
311 $ lsame( normin, 'N' ) ) THEN
312 info = -4
313 ELSE IF( n.LT.0 ) THEN
314 info = -5
315 ELSE IF( kd.LT.0 ) THEN
316 info = -6
317 ELSE IF( ldab.LT.kd+1 ) THEN
318 info = -8
319 END IF
320 IF( info.NE.0 ) THEN
321 CALL xerbla( 'CLATBS', -info )
322 RETURN
323 END IF
324*
325* Quick return if possible
326*
327 IF( n.EQ.0 )
328 $ RETURN
329*
330* Determine machine dependent parameters to control overflow.
331*
332 smlnum = slamch( 'Safe minimum' )
333 bignum = one / smlnum
334 CALL slabad( smlnum, bignum )
335 smlnum = smlnum / slamch( 'Precision' )
336 bignum = one / smlnum
337 scale = one
338*
339 IF( lsame( normin, 'N' ) ) THEN
340*
341* Compute the 1-norm of each column, not including the diagonal.
342*
343 IF( upper ) THEN
344*
345* A is upper triangular.
346*
347 DO 10 j = 1, n
348 jlen = min( kd, j-1 )
349 cnorm( j ) = scasum( jlen, ab( kd+1-jlen, j ), 1 )
350 10 CONTINUE
351 ELSE
352*
353* A is lower triangular.
354*
355 DO 20 j = 1, n
356 jlen = min( kd, n-j )
357 IF( jlen.GT.0 ) THEN
358 cnorm( j ) = scasum( jlen, ab( 2, j ), 1 )
359 ELSE
360 cnorm( j ) = zero
361 END IF
362 20 CONTINUE
363 END IF
364 END IF
365*
366* Scale the column norms by TSCAL if the maximum element in CNORM is
367* greater than BIGNUM/2.
368*
369 imax = isamax( n, cnorm, 1 )
370 tmax = cnorm( imax )
371 IF( tmax.LE.bignum*half ) THEN
372 tscal = one
373 ELSE
374 tscal = half / ( smlnum*tmax )
375 CALL sscal( n, tscal, cnorm, 1 )
376 END IF
377*
378* Compute a bound on the computed solution vector to see if the
379* Level 2 BLAS routine CTBSV can be used.
380*
381 xmax = zero
382 DO 30 j = 1, n
383 xmax = max( xmax, cabs2( x( j ) ) )
384 30 CONTINUE
385 xbnd = xmax
386 IF( notran ) THEN
387*
388* Compute the growth in A * x = b.
389*
390 IF( upper ) THEN
391 jfirst = n
392 jlast = 1
393 jinc = -1
394 maind = kd + 1
395 ELSE
396 jfirst = 1
397 jlast = n
398 jinc = 1
399 maind = 1
400 END IF
401*
402 IF( tscal.NE.one ) THEN
403 grow = zero
404 GO TO 60
405 END IF
406*
407 IF( nounit ) THEN
408*
409* A is non-unit triangular.
410*
411* Compute GROW = 1/G(j) and XBND = 1/M(j).
412* Initially, G(0) = max{x(i), i=1,...,n}.
413*
414 grow = half / max( xbnd, smlnum )
415 xbnd = grow
416 DO 40 j = jfirst, jlast, jinc
417*
418* Exit the loop if the growth factor is too small.
419*
420 IF( grow.LE.smlnum )
421 $ GO TO 60
422*
423 tjjs = ab( maind, j )
424 tjj = cabs1( tjjs )
425*
426 IF( tjj.GE.smlnum ) THEN
427*
428* M(j) = G(j-1) / abs(A(j,j))
429*
430 xbnd = min( xbnd, min( one, tjj )*grow )
431 ELSE
432*
433* M(j) could overflow, set XBND to 0.
434*
435 xbnd = zero
436 END IF
437*
438 IF( tjj+cnorm( j ).GE.smlnum ) THEN
439*
440* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
441*
442 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
443 ELSE
444*
445* G(j) could overflow, set GROW to 0.
446*
447 grow = zero
448 END IF
449 40 CONTINUE
450 grow = xbnd
451 ELSE
452*
453* A is unit triangular.
454*
455* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
456*
457 grow = min( one, half / max( xbnd, smlnum ) )
458 DO 50 j = jfirst, jlast, jinc
459*
460* Exit the loop if the growth factor is too small.
461*
462 IF( grow.LE.smlnum )
463 $ GO TO 60
464*
465* G(j) = G(j-1)*( 1 + CNORM(j) )
466*
467 grow = grow*( one / ( one+cnorm( j ) ) )
468 50 CONTINUE
469 END IF
470 60 CONTINUE
471*
472 ELSE
473*
474* Compute the growth in A**T * x = b or A**H * x = b.
475*
476 IF( upper ) THEN
477 jfirst = 1
478 jlast = n
479 jinc = 1
480 maind = kd + 1
481 ELSE
482 jfirst = n
483 jlast = 1
484 jinc = -1
485 maind = 1
486 END IF
487*
488 IF( tscal.NE.one ) THEN
489 grow = zero
490 GO TO 90
491 END IF
492*
493 IF( nounit ) THEN
494*
495* A is non-unit triangular.
496*
497* Compute GROW = 1/G(j) and XBND = 1/M(j).
498* Initially, M(0) = max{x(i), i=1,...,n}.
499*
500 grow = half / max( xbnd, smlnum )
501 xbnd = grow
502 DO 70 j = jfirst, jlast, jinc
503*
504* Exit the loop if the growth factor is too small.
505*
506 IF( grow.LE.smlnum )
507 $ GO TO 90
508*
509* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
510*
511 xj = one + cnorm( j )
512 grow = min( grow, xbnd / xj )
513*
514 tjjs = ab( maind, j )
515 tjj = cabs1( tjjs )
516*
517 IF( tjj.GE.smlnum ) THEN
518*
519* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
520*
521 IF( xj.GT.tjj )
522 $ xbnd = xbnd*( tjj / xj )
523 ELSE
524*
525* M(j) could overflow, set XBND to 0.
526*
527 xbnd = zero
528 END IF
529 70 CONTINUE
530 grow = min( grow, xbnd )
531 ELSE
532*
533* A is unit triangular.
534*
535* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
536*
537 grow = min( one, half / max( xbnd, smlnum ) )
538 DO 80 j = jfirst, jlast, jinc
539*
540* Exit the loop if the growth factor is too small.
541*
542 IF( grow.LE.smlnum )
543 $ GO TO 90
544*
545* G(j) = ( 1 + CNORM(j) )*G(j-1)
546*
547 xj = one + cnorm( j )
548 grow = grow / xj
549 80 CONTINUE
550 END IF
551 90 CONTINUE
552 END IF
553*
554 IF( ( grow*tscal ).GT.smlnum ) THEN
555*
556* Use the Level 2 BLAS solve if the reciprocal of the bound on
557* elements of X is not too small.
558*
559 CALL ctbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 )
560 ELSE
561*
562* Use a Level 1 BLAS solve, scaling intermediate results.
563*
564 IF( xmax.GT.bignum*half ) THEN
565*
566* Scale X so that its components are less than or equal to
567* BIGNUM in absolute value.
568*
569 scale = ( bignum*half ) / xmax
570 CALL csscal( n, scale, x, 1 )
571 xmax = bignum
572 ELSE
573 xmax = xmax*two
574 END IF
575*
576 IF( notran ) THEN
577*
578* Solve A * x = b
579*
580 DO 110 j = jfirst, jlast, jinc
581*
582* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
583*
584 xj = cabs1( x( j ) )
585 IF( nounit ) THEN
586 tjjs = ab( maind, j )*tscal
587 ELSE
588 tjjs = tscal
589 IF( tscal.EQ.one )
590 $ GO TO 105
591 END IF
592 tjj = cabs1( tjjs )
593 IF( tjj.GT.smlnum ) THEN
594*
595* abs(A(j,j)) > SMLNUM:
596*
597 IF( tjj.LT.one ) THEN
598 IF( xj.GT.tjj*bignum ) THEN
599*
600* Scale x by 1/b(j).
601*
602 rec = one / xj
603 CALL csscal( n, rec, x, 1 )
604 scale = scale*rec
605 xmax = xmax*rec
606 END IF
607 END IF
608 x( j ) = cladiv( x( j ), tjjs )
609 xj = cabs1( x( j ) )
610 ELSE IF( tjj.GT.zero ) THEN
611*
612* 0 < abs(A(j,j)) <= SMLNUM:
613*
614 IF( xj.GT.tjj*bignum ) THEN
615*
616* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
617* to avoid overflow when dividing by A(j,j).
618*
619 rec = ( tjj*bignum ) / xj
620 IF( cnorm( j ).GT.one ) THEN
621*
622* Scale by 1/CNORM(j) to avoid overflow when
623* multiplying x(j) times column j.
624*
625 rec = rec / cnorm( j )
626 END IF
627 CALL csscal( n, rec, x, 1 )
628 scale = scale*rec
629 xmax = xmax*rec
630 END IF
631 x( j ) = cladiv( x( j ), tjjs )
632 xj = cabs1( x( j ) )
633 ELSE
634*
635* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
636* scale = 0, and compute a solution to A*x = 0.
637*
638 DO 100 i = 1, n
639 x( i ) = zero
640 100 CONTINUE
641 x( j ) = one
642 xj = one
643 scale = zero
644 xmax = zero
645 END IF
646 105 CONTINUE
647*
648* Scale x if necessary to avoid overflow when adding a
649* multiple of column j of A.
650*
651 IF( xj.GT.one ) THEN
652 rec = one / xj
653 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
654*
655* Scale x by 1/(2*abs(x(j))).
656*
657 rec = rec*half
658 CALL csscal( n, rec, x, 1 )
659 scale = scale*rec
660 END IF
661 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
662*
663* Scale x by 1/2.
664*
665 CALL csscal( n, half, x, 1 )
666 scale = scale*half
667 END IF
668*
669 IF( upper ) THEN
670 IF( j.GT.1 ) THEN
671*
672* Compute the update
673* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
674* x(j)* A(max(1,j-kd):j-1,j)
675*
676 jlen = min( kd, j-1 )
677 CALL caxpy( jlen, -x( j )*tscal,
678 $ ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 )
679 i = icamax( j-1, x, 1 )
680 xmax = cabs1( x( i ) )
681 END IF
682 ELSE IF( j.LT.n ) THEN
683*
684* Compute the update
685* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
686* x(j) * A(j+1:min(j+kd,n),j)
687*
688 jlen = min( kd, n-j )
689 IF( jlen.GT.0 )
690 $ CALL caxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,
691 $ x( j+1 ), 1 )
692 i = j + icamax( n-j, x( j+1 ), 1 )
693 xmax = cabs1( x( i ) )
694 END IF
695 110 CONTINUE
696*
697 ELSE IF( lsame( trans, 'T' ) ) THEN
698*
699* Solve A**T * x = b
700*
701 DO 150 j = jfirst, jlast, jinc
702*
703* Compute x(j) = b(j) - sum A(k,j)*x(k).
704* k<>j
705*
706 xj = cabs1( x( j ) )
707 uscal = tscal
708 rec = one / max( xmax, one )
709 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
710*
711* If x(j) could overflow, scale x by 1/(2*XMAX).
712*
713 rec = rec*half
714 IF( nounit ) THEN
715 tjjs = ab( maind, j )*tscal
716 ELSE
717 tjjs = tscal
718 END IF
719 tjj = cabs1( tjjs )
720 IF( tjj.GT.one ) THEN
721*
722* Divide by A(j,j) when scaling x if A(j,j) > 1.
723*
724 rec = min( one, rec*tjj )
725 uscal = cladiv( uscal, tjjs )
726 END IF
727 IF( rec.LT.one ) THEN
728 CALL csscal( n, rec, x, 1 )
729 scale = scale*rec
730 xmax = xmax*rec
731 END IF
732 END IF
733*
734 csumj = zero
735 IF( uscal.EQ.cmplx( one ) ) THEN
736*
737* If the scaling needed for A in the dot product is 1,
738* call CDOTU to perform the dot product.
739*
740 IF( upper ) THEN
741 jlen = min( kd, j-1 )
742 csumj = cdotu( jlen, ab( kd+1-jlen, j ), 1,
743 $ x( j-jlen ), 1 )
744 ELSE
745 jlen = min( kd, n-j )
746 IF( jlen.GT.1 )
747 $ csumj = cdotu( jlen, ab( 2, j ), 1, x( j+1 ),
748 $ 1 )
749 END IF
750 ELSE
751*
752* Otherwise, use in-line code for the dot product.
753*
754 IF( upper ) THEN
755 jlen = min( kd, j-1 )
756 DO 120 i = 1, jlen
757 csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*
758 $ x( j-jlen-1+i )
759 120 CONTINUE
760 ELSE
761 jlen = min( kd, n-j )
762 DO 130 i = 1, jlen
763 csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
764 130 CONTINUE
765 END IF
766 END IF
767*
768 IF( uscal.EQ.cmplx( tscal ) ) THEN
769*
770* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
771* was not used to scale the dotproduct.
772*
773 x( j ) = x( j ) - csumj
774 xj = cabs1( x( j ) )
775 IF( nounit ) THEN
776*
777* Compute x(j) = x(j) / A(j,j), scaling if necessary.
778*
779 tjjs = ab( maind, j )*tscal
780 ELSE
781 tjjs = tscal
782 IF( tscal.EQ.one )
783 $ GO TO 145
784 END IF
785 tjj = cabs1( tjjs )
786 IF( tjj.GT.smlnum ) THEN
787*
788* abs(A(j,j)) > SMLNUM:
789*
790 IF( tjj.LT.one ) THEN
791 IF( xj.GT.tjj*bignum ) THEN
792*
793* Scale X by 1/abs(x(j)).
794*
795 rec = one / xj
796 CALL csscal( n, rec, x, 1 )
797 scale = scale*rec
798 xmax = xmax*rec
799 END IF
800 END IF
801 x( j ) = cladiv( x( j ), tjjs )
802 ELSE IF( tjj.GT.zero ) THEN
803*
804* 0 < abs(A(j,j)) <= SMLNUM:
805*
806 IF( xj.GT.tjj*bignum ) THEN
807*
808* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
809*
810 rec = ( tjj*bignum ) / xj
811 CALL csscal( n, rec, x, 1 )
812 scale = scale*rec
813 xmax = xmax*rec
814 END IF
815 x( j ) = cladiv( x( j ), tjjs )
816 ELSE
817*
818* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
819* scale = 0 and compute a solution to A**T *x = 0.
820*
821 DO 140 i = 1, n
822 x( i ) = zero
823 140 CONTINUE
824 x( j ) = one
825 scale = zero
826 xmax = zero
827 END IF
828 145 CONTINUE
829 ELSE
830*
831* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
832* product has already been divided by 1/A(j,j).
833*
834 x( j ) = cladiv( x( j ), tjjs ) - csumj
835 END IF
836 xmax = max( xmax, cabs1( x( j ) ) )
837 150 CONTINUE
838*
839 ELSE
840*
841* Solve A**H * x = b
842*
843 DO 190 j = jfirst, jlast, jinc
844*
845* Compute x(j) = b(j) - sum A(k,j)*x(k).
846* k<>j
847*
848 xj = cabs1( x( j ) )
849 uscal = tscal
850 rec = one / max( xmax, one )
851 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
852*
853* If x(j) could overflow, scale x by 1/(2*XMAX).
854*
855 rec = rec*half
856 IF( nounit ) THEN
857 tjjs = conjg( ab( maind, j ) )*tscal
858 ELSE
859 tjjs = tscal
860 END IF
861 tjj = cabs1( tjjs )
862 IF( tjj.GT.one ) THEN
863*
864* Divide by A(j,j) when scaling x if A(j,j) > 1.
865*
866 rec = min( one, rec*tjj )
867 uscal = cladiv( uscal, tjjs )
868 END IF
869 IF( rec.LT.one ) THEN
870 CALL csscal( n, rec, x, 1 )
871 scale = scale*rec
872 xmax = xmax*rec
873 END IF
874 END IF
875*
876 csumj = zero
877 IF( uscal.EQ.cmplx( one ) ) THEN
878*
879* If the scaling needed for A in the dot product is 1,
880* call CDOTC to perform the dot product.
881*
882 IF( upper ) THEN
883 jlen = min( kd, j-1 )
884 csumj = cdotc( jlen, ab( kd+1-jlen, j ), 1,
885 $ x( j-jlen ), 1 )
886 ELSE
887 jlen = min( kd, n-j )
888 IF( jlen.GT.1 )
889 $ csumj = cdotc( jlen, ab( 2, j ), 1, x( j+1 ),
890 $ 1 )
891 END IF
892 ELSE
893*
894* Otherwise, use in-line code for the dot product.
895*
896 IF( upper ) THEN
897 jlen = min( kd, j-1 )
898 DO 160 i = 1, jlen
899 csumj = csumj + ( conjg( ab( kd+i-jlen, j ) )*
900 $ uscal )*x( j-jlen-1+i )
901 160 CONTINUE
902 ELSE
903 jlen = min( kd, n-j )
904 DO 170 i = 1, jlen
905 csumj = csumj + ( conjg( ab( i+1, j ) )*uscal )*
906 $ x( j+i )
907 170 CONTINUE
908 END IF
909 END IF
910*
911 IF( uscal.EQ.cmplx( tscal ) ) THEN
912*
913* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
914* was not used to scale the dotproduct.
915*
916 x( j ) = x( j ) - csumj
917 xj = cabs1( x( j ) )
918 IF( nounit ) THEN
919*
920* Compute x(j) = x(j) / A(j,j), scaling if necessary.
921*
922 tjjs = conjg( ab( maind, j ) )*tscal
923 ELSE
924 tjjs = tscal
925 IF( tscal.EQ.one )
926 $ GO TO 185
927 END IF
928 tjj = cabs1( tjjs )
929 IF( tjj.GT.smlnum ) THEN
930*
931* abs(A(j,j)) > SMLNUM:
932*
933 IF( tjj.LT.one ) THEN
934 IF( xj.GT.tjj*bignum ) THEN
935*
936* Scale X by 1/abs(x(j)).
937*
938 rec = one / xj
939 CALL csscal( n, rec, x, 1 )
940 scale = scale*rec
941 xmax = xmax*rec
942 END IF
943 END IF
944 x( j ) = cladiv( x( j ), tjjs )
945 ELSE IF( tjj.GT.zero ) THEN
946*
947* 0 < abs(A(j,j)) <= SMLNUM:
948*
949 IF( xj.GT.tjj*bignum ) THEN
950*
951* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
952*
953 rec = ( tjj*bignum ) / xj
954 CALL csscal( n, rec, x, 1 )
955 scale = scale*rec
956 xmax = xmax*rec
957 END IF
958 x( j ) = cladiv( x( j ), tjjs )
959 ELSE
960*
961* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
962* scale = 0 and compute a solution to A**H *x = 0.
963*
964 DO 180 i = 1, n
965 x( i ) = zero
966 180 CONTINUE
967 x( j ) = one
968 scale = zero
969 xmax = zero
970 END IF
971 185 CONTINUE
972 ELSE
973*
974* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
975* product has already been divided by 1/A(j,j).
976*
977 x( j ) = cladiv( x( j ), tjjs ) - csumj
978 END IF
979 xmax = max( xmax, cabs1( x( j ) ) )
980 190 CONTINUE
981 END IF
982 scale = scale / tscal
983 END IF
984*
985* Scale the column norms by 1/TSCAL for return.
986*
987 IF( tscal.NE.one ) THEN
988 CALL sscal( n, one / tscal, cnorm, 1 )
989 END IF
990*
991 RETURN
992*
993* End of CLATBS
994*
cdotu
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
Definition cdotu.f:83
ctbsv
subroutine ctbsv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBSV
Definition ctbsv.f:189
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79

◆ clatdf()

subroutine clatdf ( integer ijob,
integer n,
complex, dimension( ldz, * ) z,
integer ldz,
complex, dimension( * ) rhs,
real rdsum,
real rdscal,
integer, dimension( * ) ipiv,
integer, dimension( * ) jpiv )

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

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

Purpose:
!>
!> CLATDF computes the contribution to the reciprocal Dif-estimate
!> by solving for x in Z * x = b, where b is chosen such that the norm
!> of x is as large as possible. It is assumed that LU decomposition
!> of Z has been computed by CGETC2. On entry RHS = f holds the
!> contribution from earlier solved sub-systems, and on return RHS = x.
!>
!> The factorization of Z returned by CGETC2 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 CGECON, 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 COMPLEX array, dimension (LDZ, N)
!>          On entry, the LU part of the factorization of the n-by-n
!>          matrix Z computed by CGETC2:  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 COMPLEX 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 REAL
!>          On entry, the sum of squares of computed contributions to
!>          the Dif-estimate under computation by CTGSYL, 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 CTGSY2 is called by CTGSYL.
!>
[in,out]RDSCAL
!>          RDSCAL is REAL
!>          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 CTGSY2 is called by
!>          CTGSYL.
!>
[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 UMINF-95.05, Department of Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.

Definition at line 167 of file clatdf.f.

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

◆ clatps()

subroutine clatps ( character uplo,
character trans,
character diag,
character normin,
integer n,
complex, dimension( * ) ap,
complex, dimension( * ) x,
real scale,
real, dimension( * ) cnorm,
integer info )

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

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

Purpose:
!>
!> CLATPS solves one of the triangular systems
!>
!>    A * x = s*b,  A**T * x = s*b,  or  A**H * 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, A**H denotes the conjugate 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 CTPSV 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**H * x = s*b  (Conjugate 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 COMPLEX 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 COMPLEX 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 REAL
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  A**T * x = s*b,  or  A**H * 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 REAL 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, CTPSV
!>  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 CTPSV 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  or
!>  A**H *x = b.  The basic algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]' * 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 CTPSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 229 of file clatps.f.

231*
232* -- LAPACK auxiliary routine --
233* -- LAPACK is a software package provided by Univ. of Tennessee, --
234* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
235*
236* .. Scalar Arguments ..
237 CHARACTER DIAG, NORMIN, TRANS, UPLO
238 INTEGER INFO, N
239 REAL SCALE
240* ..
241* .. Array Arguments ..
242 REAL CNORM( * )
243 COMPLEX AP( * ), X( * )
244* ..
245*
246* =====================================================================
247*
248* .. Parameters ..
249 REAL ZERO, HALF, ONE, TWO
250 parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0,
251 $ two = 2.0e+0 )
252* ..
253* .. Local Scalars ..
254 LOGICAL NOTRAN, NOUNIT, UPPER
255 INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
256 REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
257 $ XBND, XJ, XMAX
258 COMPLEX CSUMJ, TJJS, USCAL, ZDUM
259* ..
260* .. External Functions ..
261 LOGICAL LSAME
262 INTEGER ICAMAX, ISAMAX
263 REAL SCASUM, SLAMCH
264 COMPLEX CDOTC, CDOTU, CLADIV
265 EXTERNAL lsame, icamax, isamax, scasum, slamch, cdotc,
266 $ cdotu, cladiv
267* ..
268* .. External Subroutines ..
269 EXTERNAL caxpy, csscal, ctpsv, slabad, sscal, xerbla
270* ..
271* .. Intrinsic Functions ..
272 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
273* ..
274* .. Statement Functions ..
275 REAL CABS1, CABS2
276* ..
277* .. Statement Function definitions ..
278 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
279 cabs2( zdum ) = abs( real( zdum ) / 2. ) +
280 $ abs( aimag( zdum ) / 2. )
281* ..
282* .. Executable Statements ..
283*
284 info = 0
285 upper = lsame( uplo, 'U' )
286 notran = lsame( trans, 'N' )
287 nounit = lsame( diag, 'N' )
288*
289* Test the input parameters.
290*
291 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
292 info = -1
293 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
294 $ lsame( trans, 'C' ) ) THEN
295 info = -2
296 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
297 info = -3
298 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
299 $ lsame( normin, 'N' ) ) THEN
300 info = -4
301 ELSE IF( n.LT.0 ) THEN
302 info = -5
303 END IF
304 IF( info.NE.0 ) THEN
305 CALL xerbla( 'CLATPS', -info )
306 RETURN
307 END IF
308*
309* Quick return if possible
310*
311 IF( n.EQ.0 )
312 $ RETURN
313*
314* Determine machine dependent parameters to control overflow.
315*
316 smlnum = slamch( 'Safe minimum' )
317 bignum = one / smlnum
318 CALL slabad( smlnum, bignum )
319 smlnum = smlnum / slamch( 'Precision' )
320 bignum = one / smlnum
321 scale = one
322*
323 IF( lsame( normin, 'N' ) ) THEN
324*
325* Compute the 1-norm of each column, not including the diagonal.
326*
327 IF( upper ) THEN
328*
329* A is upper triangular.
330*
331 ip = 1
332 DO 10 j = 1, n
333 cnorm( j ) = scasum( j-1, ap( ip ), 1 )
334 ip = ip + j
335 10 CONTINUE
336 ELSE
337*
338* A is lower triangular.
339*
340 ip = 1
341 DO 20 j = 1, n - 1
342 cnorm( j ) = scasum( n-j, ap( ip+1 ), 1 )
343 ip = ip + n - j + 1
344 20 CONTINUE
345 cnorm( n ) = zero
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/2.
351*
352 imax = isamax( n, cnorm, 1 )
353 tmax = cnorm( imax )
354 IF( tmax.LE.bignum*half ) THEN
355 tscal = one
356 ELSE
357 tscal = half / ( smlnum*tmax )
358 CALL sscal( 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 CTPSV can be used.
363*
364 xmax = zero
365 DO 30 j = 1, n
366 xmax = max( xmax, cabs2( x( j ) ) )
367 30 CONTINUE
368 xbnd = xmax
369 IF( notran ) THEN
370*
371* Compute the growth in A * x = b.
372*
373 IF( upper ) THEN
374 jfirst = n
375 jlast = 1
376 jinc = -1
377 ELSE
378 jfirst = 1
379 jlast = n
380 jinc = 1
381 END IF
382*
383 IF( tscal.NE.one ) THEN
384 grow = zero
385 GO TO 60
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 = half / max( xbnd, smlnum )
396 xbnd = grow
397 ip = jfirst*( jfirst+1 ) / 2
398 jlen = n
399 DO 40 j = jfirst, jlast, jinc
400*
401* Exit the loop if the growth factor is too small.
402*
403 IF( grow.LE.smlnum )
404 $ GO TO 60
405*
406 tjjs = ap( ip )
407 tjj = cabs1( tjjs )
408*
409 IF( tjj.GE.smlnum ) THEN
410*
411* M(j) = G(j-1) / abs(A(j,j))
412*
413 xbnd = min( xbnd, min( one, tjj )*grow )
414 ELSE
415*
416* M(j) could overflow, set XBND to 0.
417*
418 xbnd = zero
419 END IF
420*
421 IF( tjj+cnorm( j ).GE.smlnum ) THEN
422*
423* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
424*
425 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
426 ELSE
427*
428* G(j) could overflow, set GROW to 0.
429*
430 grow = zero
431 END IF
432 ip = ip + jinc*jlen
433 jlen = jlen - 1
434 40 CONTINUE
435 grow = xbnd
436 ELSE
437*
438* A is unit triangular.
439*
440* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
441*
442 grow = min( one, half / max( xbnd, smlnum ) )
443 DO 50 j = jfirst, jlast, jinc
444*
445* Exit the loop if the growth factor is too small.
446*
447 IF( grow.LE.smlnum )
448 $ GO TO 60
449*
450* G(j) = G(j-1)*( 1 + CNORM(j) )
451*
452 grow = grow*( one / ( one+cnorm( j ) ) )
453 50 CONTINUE
454 END IF
455 60 CONTINUE
456*
457 ELSE
458*
459* Compute the growth in A**T * x = b or A**H * x = b.
460*
461 IF( upper ) THEN
462 jfirst = 1
463 jlast = n
464 jinc = 1
465 ELSE
466 jfirst = n
467 jlast = 1
468 jinc = -1
469 END IF
470*
471 IF( tscal.NE.one ) THEN
472 grow = zero
473 GO TO 90
474 END IF
475*
476 IF( nounit ) THEN
477*
478* A is non-unit triangular.
479*
480* Compute GROW = 1/G(j) and XBND = 1/M(j).
481* Initially, M(0) = max{x(i), i=1,...,n}.
482*
483 grow = half / max( xbnd, smlnum )
484 xbnd = grow
485 ip = jfirst*( jfirst+1 ) / 2
486 jlen = 1
487 DO 70 j = jfirst, jlast, jinc
488*
489* Exit the loop if the growth factor is too small.
490*
491 IF( grow.LE.smlnum )
492 $ GO TO 90
493*
494* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
495*
496 xj = one + cnorm( j )
497 grow = min( grow, xbnd / xj )
498*
499 tjjs = ap( ip )
500 tjj = cabs1( tjjs )
501*
502 IF( tjj.GE.smlnum ) THEN
503*
504* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
505*
506 IF( xj.GT.tjj )
507 $ xbnd = xbnd*( tjj / xj )
508 ELSE
509*
510* M(j) could overflow, set XBND to 0.
511*
512 xbnd = zero
513 END IF
514 jlen = jlen + 1
515 ip = ip + jinc*jlen
516 70 CONTINUE
517 grow = min( grow, xbnd )
518 ELSE
519*
520* A is unit triangular.
521*
522* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
523*
524 grow = min( one, half / max( xbnd, smlnum ) )
525 DO 80 j = jfirst, jlast, jinc
526*
527* Exit the loop if the growth factor is too small.
528*
529 IF( grow.LE.smlnum )
530 $ GO TO 90
531*
532* G(j) = ( 1 + CNORM(j) )*G(j-1)
533*
534 xj = one + cnorm( j )
535 grow = grow / xj
536 80 CONTINUE
537 END IF
538 90 CONTINUE
539 END IF
540*
541 IF( ( grow*tscal ).GT.smlnum ) THEN
542*
543* Use the Level 2 BLAS solve if the reciprocal of the bound on
544* elements of X is not too small.
545*
546 CALL ctpsv( uplo, trans, diag, n, ap, x, 1 )
547 ELSE
548*
549* Use a Level 1 BLAS solve, scaling intermediate results.
550*
551 IF( xmax.GT.bignum*half ) THEN
552*
553* Scale X so that its components are less than or equal to
554* BIGNUM in absolute value.
555*
556 scale = ( bignum*half ) / xmax
557 CALL csscal( n, scale, x, 1 )
558 xmax = bignum
559 ELSE
560 xmax = xmax*two
561 END IF
562*
563 IF( notran ) THEN
564*
565* Solve A * x = b
566*
567 ip = jfirst*( jfirst+1 ) / 2
568 DO 110 j = jfirst, jlast, jinc
569*
570* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
571*
572 xj = cabs1( x( j ) )
573 IF( nounit ) THEN
574 tjjs = ap( ip )*tscal
575 ELSE
576 tjjs = tscal
577 IF( tscal.EQ.one )
578 $ GO TO 105
579 END IF
580 tjj = cabs1( tjjs )
581 IF( tjj.GT.smlnum ) THEN
582*
583* abs(A(j,j)) > SMLNUM:
584*
585 IF( tjj.LT.one ) THEN
586 IF( xj.GT.tjj*bignum ) THEN
587*
588* Scale x by 1/b(j).
589*
590 rec = one / xj
591 CALL csscal( n, rec, x, 1 )
592 scale = scale*rec
593 xmax = xmax*rec
594 END IF
595 END IF
596 x( j ) = cladiv( x( j ), tjjs )
597 xj = cabs1( x( j ) )
598 ELSE IF( tjj.GT.zero ) THEN
599*
600* 0 < abs(A(j,j)) <= SMLNUM:
601*
602 IF( xj.GT.tjj*bignum ) THEN
603*
604* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
605* to avoid overflow when dividing by A(j,j).
606*
607 rec = ( tjj*bignum ) / xj
608 IF( cnorm( j ).GT.one ) THEN
609*
610* Scale by 1/CNORM(j) to avoid overflow when
611* multiplying x(j) times column j.
612*
613 rec = rec / cnorm( j )
614 END IF
615 CALL csscal( n, rec, x, 1 )
616 scale = scale*rec
617 xmax = xmax*rec
618 END IF
619 x( j ) = cladiv( x( j ), tjjs )
620 xj = cabs1( x( j ) )
621 ELSE
622*
623* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
624* scale = 0, and compute a solution to A*x = 0.
625*
626 DO 100 i = 1, n
627 x( i ) = zero
628 100 CONTINUE
629 x( j ) = one
630 xj = one
631 scale = zero
632 xmax = zero
633 END IF
634 105 CONTINUE
635*
636* Scale x if necessary to avoid overflow when adding a
637* multiple of column j of A.
638*
639 IF( xj.GT.one ) THEN
640 rec = one / xj
641 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
642*
643* Scale x by 1/(2*abs(x(j))).
644*
645 rec = rec*half
646 CALL csscal( n, rec, x, 1 )
647 scale = scale*rec
648 END IF
649 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
650*
651* Scale x by 1/2.
652*
653 CALL csscal( n, half, x, 1 )
654 scale = scale*half
655 END IF
656*
657 IF( upper ) THEN
658 IF( j.GT.1 ) THEN
659*
660* Compute the update
661* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
662*
663 CALL caxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,
664 $ 1 )
665 i = icamax( j-1, x, 1 )
666 xmax = cabs1( x( i ) )
667 END IF
668 ip = ip - j
669 ELSE
670 IF( j.LT.n ) THEN
671*
672* Compute the update
673* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
674*
675 CALL caxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1,
676 $ x( j+1 ), 1 )
677 i = j + icamax( n-j, x( j+1 ), 1 )
678 xmax = cabs1( x( i ) )
679 END IF
680 ip = ip + n - j + 1
681 END IF
682 110 CONTINUE
683*
684 ELSE IF( lsame( trans, 'T' ) ) THEN
685*
686* Solve A**T * x = b
687*
688 ip = jfirst*( jfirst+1 ) / 2
689 jlen = 1
690 DO 150 j = jfirst, jlast, jinc
691*
692* Compute x(j) = b(j) - sum A(k,j)*x(k).
693* k<>j
694*
695 xj = cabs1( x( j ) )
696 uscal = tscal
697 rec = one / max( xmax, one )
698 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
699*
700* If x(j) could overflow, scale x by 1/(2*XMAX).
701*
702 rec = rec*half
703 IF( nounit ) THEN
704 tjjs = ap( ip )*tscal
705 ELSE
706 tjjs = tscal
707 END IF
708 tjj = cabs1( tjjs )
709 IF( tjj.GT.one ) THEN
710*
711* Divide by A(j,j) when scaling x if A(j,j) > 1.
712*
713 rec = min( one, rec*tjj )
714 uscal = cladiv( uscal, tjjs )
715 END IF
716 IF( rec.LT.one ) THEN
717 CALL csscal( n, rec, x, 1 )
718 scale = scale*rec
719 xmax = xmax*rec
720 END IF
721 END IF
722*
723 csumj = zero
724 IF( uscal.EQ.cmplx( one ) ) THEN
725*
726* If the scaling needed for A in the dot product is 1,
727* call CDOTU to perform the dot product.
728*
729 IF( upper ) THEN
730 csumj = cdotu( j-1, ap( ip-j+1 ), 1, x, 1 )
731 ELSE IF( j.LT.n ) THEN
732 csumj = cdotu( n-j, ap( ip+1 ), 1, x( j+1 ), 1 )
733 END IF
734 ELSE
735*
736* Otherwise, use in-line code for the dot product.
737*
738 IF( upper ) THEN
739 DO 120 i = 1, j - 1
740 csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
741 120 CONTINUE
742 ELSE IF( j.LT.n ) THEN
743 DO 130 i = 1, n - j
744 csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
745 130 CONTINUE
746 END IF
747 END IF
748*
749 IF( uscal.EQ.cmplx( tscal ) ) THEN
750*
751* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
752* was not used to scale the dotproduct.
753*
754 x( j ) = x( j ) - csumj
755 xj = cabs1( x( j ) )
756 IF( nounit ) THEN
757*
758* Compute x(j) = x(j) / A(j,j), scaling if necessary.
759*
760 tjjs = ap( ip )*tscal
761 ELSE
762 tjjs = tscal
763 IF( tscal.EQ.one )
764 $ GO TO 145
765 END IF
766 tjj = cabs1( tjjs )
767 IF( tjj.GT.smlnum ) THEN
768*
769* abs(A(j,j)) > SMLNUM:
770*
771 IF( tjj.LT.one ) THEN
772 IF( xj.GT.tjj*bignum ) THEN
773*
774* Scale X by 1/abs(x(j)).
775*
776 rec = one / xj
777 CALL csscal( n, rec, x, 1 )
778 scale = scale*rec
779 xmax = xmax*rec
780 END IF
781 END IF
782 x( j ) = cladiv( x( j ), tjjs )
783 ELSE IF( tjj.GT.zero ) THEN
784*
785* 0 < abs(A(j,j)) <= SMLNUM:
786*
787 IF( xj.GT.tjj*bignum ) THEN
788*
789* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
790*
791 rec = ( tjj*bignum ) / xj
792 CALL csscal( n, rec, x, 1 )
793 scale = scale*rec
794 xmax = xmax*rec
795 END IF
796 x( j ) = cladiv( x( j ), tjjs )
797 ELSE
798*
799* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
800* scale = 0 and compute a solution to A**T *x = 0.
801*
802 DO 140 i = 1, n
803 x( i ) = zero
804 140 CONTINUE
805 x( j ) = one
806 scale = zero
807 xmax = zero
808 END IF
809 145 CONTINUE
810 ELSE
811*
812* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
813* product has already been divided by 1/A(j,j).
814*
815 x( j ) = cladiv( x( j ), tjjs ) - csumj
816 END IF
817 xmax = max( xmax, cabs1( x( j ) ) )
818 jlen = jlen + 1
819 ip = ip + jinc*jlen
820 150 CONTINUE
821*
822 ELSE
823*
824* Solve A**H * x = b
825*
826 ip = jfirst*( jfirst+1 ) / 2
827 jlen = 1
828 DO 190 j = jfirst, jlast, jinc
829*
830* Compute x(j) = b(j) - sum A(k,j)*x(k).
831* k<>j
832*
833 xj = cabs1( x( j ) )
834 uscal = tscal
835 rec = one / max( xmax, one )
836 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
837*
838* If x(j) could overflow, scale x by 1/(2*XMAX).
839*
840 rec = rec*half
841 IF( nounit ) THEN
842 tjjs = conjg( ap( ip ) )*tscal
843 ELSE
844 tjjs = tscal
845 END IF
846 tjj = cabs1( tjjs )
847 IF( tjj.GT.one ) THEN
848*
849* Divide by A(j,j) when scaling x if A(j,j) > 1.
850*
851 rec = min( one, rec*tjj )
852 uscal = cladiv( uscal, tjjs )
853 END IF
854 IF( rec.LT.one ) THEN
855 CALL csscal( n, rec, x, 1 )
856 scale = scale*rec
857 xmax = xmax*rec
858 END IF
859 END IF
860*
861 csumj = zero
862 IF( uscal.EQ.cmplx( one ) ) THEN
863*
864* If the scaling needed for A in the dot product is 1,
865* call CDOTC to perform the dot product.
866*
867 IF( upper ) THEN
868 csumj = cdotc( j-1, ap( ip-j+1 ), 1, x, 1 )
869 ELSE IF( j.LT.n ) THEN
870 csumj = cdotc( n-j, ap( ip+1 ), 1, x( j+1 ), 1 )
871 END IF
872 ELSE
873*
874* Otherwise, use in-line code for the dot product.
875*
876 IF( upper ) THEN
877 DO 160 i = 1, j - 1
878 csumj = csumj + ( conjg( ap( ip-j+i ) )*uscal )*
879 $ x( i )
880 160 CONTINUE
881 ELSE IF( j.LT.n ) THEN
882 DO 170 i = 1, n - j
883 csumj = csumj + ( conjg( ap( ip+i ) )*uscal )*
884 $ x( j+i )
885 170 CONTINUE
886 END IF
887 END IF
888*
889 IF( uscal.EQ.cmplx( tscal ) ) THEN
890*
891* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
892* was not used to scale the dotproduct.
893*
894 x( j ) = x( j ) - csumj
895 xj = cabs1( x( j ) )
896 IF( nounit ) THEN
897*
898* Compute x(j) = x(j) / A(j,j), scaling if necessary.
899*
900 tjjs = conjg( ap( ip ) )*tscal
901 ELSE
902 tjjs = tscal
903 IF( tscal.EQ.one )
904 $ GO TO 185
905 END IF
906 tjj = cabs1( tjjs )
907 IF( tjj.GT.smlnum ) THEN
908*
909* abs(A(j,j)) > SMLNUM:
910*
911 IF( tjj.LT.one ) THEN
912 IF( xj.GT.tjj*bignum ) THEN
913*
914* Scale X by 1/abs(x(j)).
915*
916 rec = one / xj
917 CALL csscal( n, rec, x, 1 )
918 scale = scale*rec
919 xmax = xmax*rec
920 END IF
921 END IF
922 x( j ) = cladiv( x( j ), tjjs )
923 ELSE IF( tjj.GT.zero ) THEN
924*
925* 0 < abs(A(j,j)) <= SMLNUM:
926*
927 IF( xj.GT.tjj*bignum ) THEN
928*
929* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
930*
931 rec = ( tjj*bignum ) / xj
932 CALL csscal( n, rec, x, 1 )
933 scale = scale*rec
934 xmax = xmax*rec
935 END IF
936 x( j ) = cladiv( x( j ), tjjs )
937 ELSE
938*
939* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
940* scale = 0 and compute a solution to A**H *x = 0.
941*
942 DO 180 i = 1, n
943 x( i ) = zero
944 180 CONTINUE
945 x( j ) = one
946 scale = zero
947 xmax = zero
948 END IF
949 185 CONTINUE
950 ELSE
951*
952* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
953* product has already been divided by 1/A(j,j).
954*
955 x( j ) = cladiv( x( j ), tjjs ) - csumj
956 END IF
957 xmax = max( xmax, cabs1( x( j ) ) )
958 jlen = jlen + 1
959 ip = ip + jinc*jlen
960 190 CONTINUE
961 END IF
962 scale = scale / tscal
963 END IF
964*
965* Scale the column norms by 1/TSCAL for return.
966*
967 IF( tscal.NE.one ) THEN
968 CALL sscal( n, one / tscal, cnorm, 1 )
969 END IF
970*
971 RETURN
972*
973* End of CLATPS
974*
ctpsv
subroutine ctpsv(uplo, trans, diag, n, ap, x, incx)
CTPSV
Definition ctpsv.f:144

◆ clatrd()

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

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

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

Purpose:
!>
!> CLATRD reduces NB rows and columns of a complex Hermitian matrix A to
!> Hermitian tridiagonal form by a unitary similarity
!> transformation Q**H * 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', CLATRD reduces the last NB rows and columns of a
!> matrix, of which the upper triangle is supplied;
!> if UPLO = 'L', CLATRD reduces the first NB rows and columns of a
!> matrix, of which the lower triangle is supplied.
!>
!> This is an auxiliary routine called by CHETRD.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian 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 COMPLEX array, dimension (LDA,N)
!>          On entry, the Hermitian 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 unitary 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  unitary matrix Q as a
!>            product of elementary reflectors.
!>          See Further Details.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(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 COMPLEX 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 COMPLEX 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**H
!>
!>  where tau is a complex scalar, and v is a complex 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**H
!>
!>  where tau is a complex scalar, and v is a complex 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 Hermitian rank-2k update of the form:
!>  A := A - V*W**H - W*V**H.
!>
!>  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 198 of file clatrd.f.

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

◆ clatrs()

subroutine clatrs ( character uplo,
character trans,
character diag,
character normin,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) x,
real scale,
real, dimension( * ) cnorm,
integer info )

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

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

Purpose:
!>
!> CLATRS solves one of the triangular systems
!>
!>    A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,
!>
!> with scaling to prevent overflow.  Here A is an upper or lower
!> triangular matrix, A**T denotes the transpose of A, A**H denotes the
!> conjugate 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
!> CTRSV 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**H * x = s*b  (Conjugate 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 COMPLEX 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 COMPLEX 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 REAL
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  A**T * x = s*b,  or  A**H * 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 REAL 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, CTRSV
!>  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 CTRSV 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  or
!>  A**H *x = b.  The basic algorithm for A upper triangular is
!>
!>       for j = 1, ..., n
!>            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
!>       end
!>
!>  We simultaneously compute two bounds
!>       G(j) = bound on ( b(i) - A[1:i-1,i]' * 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 CTRSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 237 of file clatrs.f.

239*
240* -- LAPACK auxiliary routine --
241* -- LAPACK is a software package provided by Univ. of Tennessee, --
242* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
243*
244* .. Scalar Arguments ..
245 CHARACTER DIAG, NORMIN, TRANS, UPLO
246 INTEGER INFO, LDA, N
247 REAL SCALE
248* ..
249* .. Array Arguments ..
250 REAL CNORM( * )
251 COMPLEX A( LDA, * ), X( * )
252* ..
253*
254* =====================================================================
255*
256* .. Parameters ..
257 REAL ZERO, HALF, ONE, TWO
258 parameter( zero = 0.0e+0, half = 0.5e+0, one = 1.0e+0,
259 $ two = 2.0e+0 )
260* ..
261* .. Local Scalars ..
262 LOGICAL NOTRAN, NOUNIT, UPPER
263 INTEGER I, IMAX, J, JFIRST, JINC, JLAST
264 REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
265 $ XBND, XJ, XMAX
266 COMPLEX CSUMJ, TJJS, USCAL, ZDUM
267* ..
268* .. External Functions ..
269 LOGICAL LSAME
270 INTEGER ICAMAX, ISAMAX
271 REAL SCASUM, SLAMCH
272 COMPLEX CDOTC, CDOTU, CLADIV
273 EXTERNAL lsame, icamax, isamax, scasum, slamch, cdotc,
274 $ cdotu, cladiv
275* ..
276* .. External Subroutines ..
277 EXTERNAL caxpy, csscal, ctrsv, slabad, sscal, xerbla
278* ..
279* .. Intrinsic Functions ..
280 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
281* ..
282* .. Statement Functions ..
283 REAL CABS1, CABS2
284* ..
285* .. Statement Function definitions ..
286 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( zdum ) )
287 cabs2( zdum ) = abs( real( zdum ) / 2. ) +
288 $ abs( aimag( zdum ) / 2. )
289* ..
290* .. Executable Statements ..
291*
292 info = 0
293 upper = lsame( uplo, 'U' )
294 notran = lsame( trans, 'N' )
295 nounit = lsame( diag, 'N' )
296*
297* Test the input parameters.
298*
299 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
300 info = -1
301 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT.
302 $ lsame( trans, 'C' ) ) THEN
303 info = -2
304 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN
305 info = -3
306 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT.
307 $ lsame( normin, 'N' ) ) THEN
308 info = -4
309 ELSE IF( n.LT.0 ) THEN
310 info = -5
311 ELSE IF( lda.LT.max( 1, n ) ) THEN
312 info = -7
313 END IF
314 IF( info.NE.0 ) THEN
315 CALL xerbla( 'CLATRS', -info )
316 RETURN
317 END IF
318*
319* Quick return if possible
320*
321 IF( n.EQ.0 )
322 $ RETURN
323*
324* Determine machine dependent parameters to control overflow.
325*
326 smlnum = slamch( 'Safe minimum' )
327 bignum = one / smlnum
328 CALL slabad( smlnum, bignum )
329 smlnum = smlnum / slamch( 'Precision' )
330 bignum = one / smlnum
331 scale = one
332*
333 IF( lsame( normin, 'N' ) ) THEN
334*
335* Compute the 1-norm of each column, not including the diagonal.
336*
337 IF( upper ) THEN
338*
339* A is upper triangular.
340*
341 DO 10 j = 1, n
342 cnorm( j ) = scasum( j-1, a( 1, j ), 1 )
343 10 CONTINUE
344 ELSE
345*
346* A is lower triangular.
347*
348 DO 20 j = 1, n - 1
349 cnorm( j ) = scasum( n-j, a( j+1, j ), 1 )
350 20 CONTINUE
351 cnorm( n ) = zero
352 END IF
353 END IF
354*
355* Scale the column norms by TSCAL if the maximum element in CNORM is
356* greater than BIGNUM/2.
357*
358 imax = isamax( n, cnorm, 1 )
359 tmax = cnorm( imax )
360 IF( tmax.LE.bignum*half ) THEN
361 tscal = one
362 ELSE
363 tscal = half / ( smlnum*tmax )
364 CALL sscal( n, tscal, cnorm, 1 )
365 END IF
366*
367* Compute a bound on the computed solution vector to see if the
368* Level 2 BLAS routine CTRSV can be used.
369*
370 xmax = zero
371 DO 30 j = 1, n
372 xmax = max( xmax, cabs2( x( j ) ) )
373 30 CONTINUE
374 xbnd = xmax
375*
376 IF( notran ) THEN
377*
378* Compute the growth in A * x = b.
379*
380 IF( upper ) THEN
381 jfirst = n
382 jlast = 1
383 jinc = -1
384 ELSE
385 jfirst = 1
386 jlast = n
387 jinc = 1
388 END IF
389*
390 IF( tscal.NE.one ) THEN
391 grow = zero
392 GO TO 60
393 END IF
394*
395 IF( nounit ) THEN
396*
397* A is non-unit triangular.
398*
399* Compute GROW = 1/G(j) and XBND = 1/M(j).
400* Initially, G(0) = max{x(i), i=1,...,n}.
401*
402 grow = half / max( xbnd, smlnum )
403 xbnd = grow
404 DO 40 j = jfirst, jlast, jinc
405*
406* Exit the loop if the growth factor is too small.
407*
408 IF( grow.LE.smlnum )
409 $ GO TO 60
410*
411 tjjs = a( j, j )
412 tjj = cabs1( tjjs )
413*
414 IF( tjj.GE.smlnum ) THEN
415*
416* M(j) = G(j-1) / abs(A(j,j))
417*
418 xbnd = min( xbnd, min( one, tjj )*grow )
419 ELSE
420*
421* M(j) could overflow, set XBND to 0.
422*
423 xbnd = zero
424 END IF
425*
426 IF( tjj+cnorm( j ).GE.smlnum ) THEN
427*
428* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
429*
430 grow = grow*( tjj / ( tjj+cnorm( j ) ) )
431 ELSE
432*
433* G(j) could overflow, set GROW to 0.
434*
435 grow = zero
436 END IF
437 40 CONTINUE
438 grow = xbnd
439 ELSE
440*
441* A is unit triangular.
442*
443* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
444*
445 grow = min( one, half / max( xbnd, smlnum ) )
446 DO 50 j = jfirst, jlast, jinc
447*
448* Exit the loop if the growth factor is too small.
449*
450 IF( grow.LE.smlnum )
451 $ GO TO 60
452*
453* G(j) = G(j-1)*( 1 + CNORM(j) )
454*
455 grow = grow*( one / ( one+cnorm( j ) ) )
456 50 CONTINUE
457 END IF
458 60 CONTINUE
459*
460 ELSE
461*
462* Compute the growth in A**T * x = b or A**H * x = b.
463*
464 IF( upper ) THEN
465 jfirst = 1
466 jlast = n
467 jinc = 1
468 ELSE
469 jfirst = n
470 jlast = 1
471 jinc = -1
472 END IF
473*
474 IF( tscal.NE.one ) THEN
475 grow = zero
476 GO TO 90
477 END IF
478*
479 IF( nounit ) THEN
480*
481* A is non-unit triangular.
482*
483* Compute GROW = 1/G(j) and XBND = 1/M(j).
484* Initially, M(0) = max{x(i), i=1,...,n}.
485*
486 grow = half / max( xbnd, smlnum )
487 xbnd = grow
488 DO 70 j = jfirst, jlast, jinc
489*
490* Exit the loop if the growth factor is too small.
491*
492 IF( grow.LE.smlnum )
493 $ GO TO 90
494*
495* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
496*
497 xj = one + cnorm( j )
498 grow = min( grow, xbnd / xj )
499*
500 tjjs = a( j, j )
501 tjj = cabs1( tjjs )
502*
503 IF( tjj.GE.smlnum ) THEN
504*
505* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
506*
507 IF( xj.GT.tjj )
508 $ xbnd = xbnd*( tjj / xj )
509 ELSE
510*
511* M(j) could overflow, set XBND to 0.
512*
513 xbnd = zero
514 END IF
515 70 CONTINUE
516 grow = min( grow, xbnd )
517 ELSE
518*
519* A is unit triangular.
520*
521* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
522*
523 grow = min( one, half / max( xbnd, smlnum ) )
524 DO 80 j = jfirst, jlast, jinc
525*
526* Exit the loop if the growth factor is too small.
527*
528 IF( grow.LE.smlnum )
529 $ GO TO 90
530*
531* G(j) = ( 1 + CNORM(j) )*G(j-1)
532*
533 xj = one + cnorm( j )
534 grow = grow / xj
535 80 CONTINUE
536 END IF
537 90 CONTINUE
538 END IF
539*
540 IF( ( grow*tscal ).GT.smlnum ) THEN
541*
542* Use the Level 2 BLAS solve if the reciprocal of the bound on
543* elements of X is not too small.
544*
545 CALL ctrsv( uplo, trans, diag, n, a, lda, x, 1 )
546 ELSE
547*
548* Use a Level 1 BLAS solve, scaling intermediate results.
549*
550 IF( xmax.GT.bignum*half ) THEN
551*
552* Scale X so that its components are less than or equal to
553* BIGNUM in absolute value.
554*
555 scale = ( bignum*half ) / xmax
556 CALL csscal( n, scale, x, 1 )
557 xmax = bignum
558 ELSE
559 xmax = xmax*two
560 END IF
561*
562 IF( notran ) THEN
563*
564* Solve A * x = b
565*
566 DO 110 j = jfirst, jlast, jinc
567*
568* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
569*
570 xj = cabs1( x( j ) )
571 IF( nounit ) THEN
572 tjjs = a( j, j )*tscal
573 ELSE
574 tjjs = tscal
575 IF( tscal.EQ.one )
576 $ GO TO 105
577 END IF
578 tjj = cabs1( tjjs )
579 IF( tjj.GT.smlnum ) THEN
580*
581* abs(A(j,j)) > SMLNUM:
582*
583 IF( tjj.LT.one ) THEN
584 IF( xj.GT.tjj*bignum ) THEN
585*
586* Scale x by 1/b(j).
587*
588 rec = one / xj
589 CALL csscal( n, rec, x, 1 )
590 scale = scale*rec
591 xmax = xmax*rec
592 END IF
593 END IF
594 x( j ) = cladiv( x( j ), tjjs )
595 xj = cabs1( x( j ) )
596 ELSE IF( tjj.GT.zero ) THEN
597*
598* 0 < abs(A(j,j)) <= SMLNUM:
599*
600 IF( xj.GT.tjj*bignum ) THEN
601*
602* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
603* to avoid overflow when dividing by A(j,j).
604*
605 rec = ( tjj*bignum ) / xj
606 IF( cnorm( j ).GT.one ) THEN
607*
608* Scale by 1/CNORM(j) to avoid overflow when
609* multiplying x(j) times column j.
610*
611 rec = rec / cnorm( j )
612 END IF
613 CALL csscal( n, rec, x, 1 )
614 scale = scale*rec
615 xmax = xmax*rec
616 END IF
617 x( j ) = cladiv( x( j ), tjjs )
618 xj = cabs1( x( j ) )
619 ELSE
620*
621* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
622* scale = 0, and compute a solution to A*x = 0.
623*
624 DO 100 i = 1, n
625 x( i ) = zero
626 100 CONTINUE
627 x( j ) = one
628 xj = one
629 scale = zero
630 xmax = zero
631 END IF
632 105 CONTINUE
633*
634* Scale x if necessary to avoid overflow when adding a
635* multiple of column j of A.
636*
637 IF( xj.GT.one ) THEN
638 rec = one / xj
639 IF( cnorm( j ).GT.( bignum-xmax )*rec ) THEN
640*
641* Scale x by 1/(2*abs(x(j))).
642*
643 rec = rec*half
644 CALL csscal( n, rec, x, 1 )
645 scale = scale*rec
646 END IF
647 ELSE IF( xj*cnorm( j ).GT.( bignum-xmax ) ) THEN
648*
649* Scale x by 1/2.
650*
651 CALL csscal( n, half, x, 1 )
652 scale = scale*half
653 END IF
654*
655 IF( upper ) THEN
656 IF( j.GT.1 ) THEN
657*
658* Compute the update
659* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
660*
661 CALL caxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,
662 $ 1 )
663 i = icamax( j-1, x, 1 )
664 xmax = cabs1( x( i ) )
665 END IF
666 ELSE
667 IF( j.LT.n ) THEN
668*
669* Compute the update
670* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
671*
672 CALL caxpy( n-j, -x( j )*tscal, a( j+1, j ), 1,
673 $ x( j+1 ), 1 )
674 i = j + icamax( n-j, x( j+1 ), 1 )
675 xmax = cabs1( x( i ) )
676 END IF
677 END IF
678 110 CONTINUE
679*
680 ELSE IF( lsame( trans, 'T' ) ) THEN
681*
682* Solve A**T * x = b
683*
684 DO 150 j = jfirst, jlast, jinc
685*
686* Compute x(j) = b(j) - sum A(k,j)*x(k).
687* k<>j
688*
689 xj = cabs1( x( j ) )
690 uscal = tscal
691 rec = one / max( xmax, one )
692 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
693*
694* If x(j) could overflow, scale x by 1/(2*XMAX).
695*
696 rec = rec*half
697 IF( nounit ) THEN
698 tjjs = a( j, j )*tscal
699 ELSE
700 tjjs = tscal
701 END IF
702 tjj = cabs1( tjjs )
703 IF( tjj.GT.one ) THEN
704*
705* Divide by A(j,j) when scaling x if A(j,j) > 1.
706*
707 rec = min( one, rec*tjj )
708 uscal = cladiv( uscal, tjjs )
709 END IF
710 IF( rec.LT.one ) THEN
711 CALL csscal( n, rec, x, 1 )
712 scale = scale*rec
713 xmax = xmax*rec
714 END IF
715 END IF
716*
717 csumj = zero
718 IF( uscal.EQ.cmplx( one ) ) THEN
719*
720* If the scaling needed for A in the dot product is 1,
721* call CDOTU to perform the dot product.
722*
723 IF( upper ) THEN
724 csumj = cdotu( j-1, a( 1, j ), 1, x, 1 )
725 ELSE IF( j.LT.n ) THEN
726 csumj = cdotu( n-j, a( j+1, j ), 1, x( j+1 ), 1 )
727 END IF
728 ELSE
729*
730* Otherwise, use in-line code for the dot product.
731*
732 IF( upper ) THEN
733 DO 120 i = 1, j - 1
734 csumj = csumj + ( a( i, j )*uscal )*x( i )
735 120 CONTINUE
736 ELSE IF( j.LT.n ) THEN
737 DO 130 i = j + 1, n
738 csumj = csumj + ( a( i, j )*uscal )*x( i )
739 130 CONTINUE
740 END IF
741 END IF
742*
743 IF( uscal.EQ.cmplx( tscal ) ) THEN
744*
745* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
746* was not used to scale the dotproduct.
747*
748 x( j ) = x( j ) - csumj
749 xj = cabs1( x( j ) )
750 IF( nounit ) THEN
751 tjjs = a( j, j )*tscal
752 ELSE
753 tjjs = tscal
754 IF( tscal.EQ.one )
755 $ GO TO 145
756 END IF
757*
758* Compute x(j) = x(j) / A(j,j), scaling if necessary.
759*
760 tjj = cabs1( tjjs )
761 IF( tjj.GT.smlnum ) THEN
762*
763* abs(A(j,j)) > SMLNUM:
764*
765 IF( tjj.LT.one ) THEN
766 IF( xj.GT.tjj*bignum ) THEN
767*
768* Scale X by 1/abs(x(j)).
769*
770 rec = one / xj
771 CALL csscal( n, rec, x, 1 )
772 scale = scale*rec
773 xmax = xmax*rec
774 END IF
775 END IF
776 x( j ) = cladiv( x( j ), tjjs )
777 ELSE IF( tjj.GT.zero ) THEN
778*
779* 0 < abs(A(j,j)) <= SMLNUM:
780*
781 IF( xj.GT.tjj*bignum ) THEN
782*
783* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
784*
785 rec = ( tjj*bignum ) / xj
786 CALL csscal( n, rec, x, 1 )
787 scale = scale*rec
788 xmax = xmax*rec
789 END IF
790 x( j ) = cladiv( x( j ), tjjs )
791 ELSE
792*
793* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
794* scale = 0 and compute a solution to A**T *x = 0.
795*
796 DO 140 i = 1, n
797 x( i ) = zero
798 140 CONTINUE
799 x( j ) = one
800 scale = zero
801 xmax = zero
802 END IF
803 145 CONTINUE
804 ELSE
805*
806* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
807* product has already been divided by 1/A(j,j).
808*
809 x( j ) = cladiv( x( j ), tjjs ) - csumj
810 END IF
811 xmax = max( xmax, cabs1( x( j ) ) )
812 150 CONTINUE
813*
814 ELSE
815*
816* Solve A**H * x = b
817*
818 DO 190 j = jfirst, jlast, jinc
819*
820* Compute x(j) = b(j) - sum A(k,j)*x(k).
821* k<>j
822*
823 xj = cabs1( x( j ) )
824 uscal = tscal
825 rec = one / max( xmax, one )
826 IF( cnorm( j ).GT.( bignum-xj )*rec ) THEN
827*
828* If x(j) could overflow, scale x by 1/(2*XMAX).
829*
830 rec = rec*half
831 IF( nounit ) THEN
832 tjjs = conjg( a( j, j ) )*tscal
833 ELSE
834 tjjs = tscal
835 END IF
836 tjj = cabs1( tjjs )
837 IF( tjj.GT.one ) THEN
838*
839* Divide by A(j,j) when scaling x if A(j,j) > 1.
840*
841 rec = min( one, rec*tjj )
842 uscal = cladiv( uscal, tjjs )
843 END IF
844 IF( rec.LT.one ) THEN
845 CALL csscal( n, rec, x, 1 )
846 scale = scale*rec
847 xmax = xmax*rec
848 END IF
849 END IF
850*
851 csumj = zero
852 IF( uscal.EQ.cmplx( one ) ) THEN
853*
854* If the scaling needed for A in the dot product is 1,
855* call CDOTC to perform the dot product.
856*
857 IF( upper ) THEN
858 csumj = cdotc( j-1, a( 1, j ), 1, x, 1 )
859 ELSE IF( j.LT.n ) THEN
860 csumj = cdotc( n-j, a( j+1, j ), 1, x( j+1 ), 1 )
861 END IF
862 ELSE
863*
864* Otherwise, use in-line code for the dot product.
865*
866 IF( upper ) THEN
867 DO 160 i = 1, j - 1
868 csumj = csumj + ( conjg( a( i, j ) )*uscal )*
869 $ x( i )
870 160 CONTINUE
871 ELSE IF( j.LT.n ) THEN
872 DO 170 i = j + 1, n
873 csumj = csumj + ( conjg( a( i, j ) )*uscal )*
874 $ x( i )
875 170 CONTINUE
876 END IF
877 END IF
878*
879 IF( uscal.EQ.cmplx( tscal ) ) THEN
880*
881* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
882* was not used to scale the dotproduct.
883*
884 x( j ) = x( j ) - csumj
885 xj = cabs1( x( j ) )
886 IF( nounit ) THEN
887 tjjs = conjg( a( j, j ) )*tscal
888 ELSE
889 tjjs = tscal
890 IF( tscal.EQ.one )
891 $ GO TO 185
892 END IF
893*
894* Compute x(j) = x(j) / A(j,j), scaling if necessary.
895*
896 tjj = cabs1( tjjs )
897 IF( tjj.GT.smlnum ) THEN
898*
899* abs(A(j,j)) > SMLNUM:
900*
901 IF( tjj.LT.one ) THEN
902 IF( xj.GT.tjj*bignum ) THEN
903*
904* Scale X by 1/abs(x(j)).
905*
906 rec = one / xj
907 CALL csscal( n, rec, x, 1 )
908 scale = scale*rec
909 xmax = xmax*rec
910 END IF
911 END IF
912 x( j ) = cladiv( x( j ), tjjs )
913 ELSE IF( tjj.GT.zero ) THEN
914*
915* 0 < abs(A(j,j)) <= SMLNUM:
916*
917 IF( xj.GT.tjj*bignum ) THEN
918*
919* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
920*
921 rec = ( tjj*bignum ) / xj
922 CALL csscal( n, rec, x, 1 )
923 scale = scale*rec
924 xmax = xmax*rec
925 END IF
926 x( j ) = cladiv( x( j ), tjjs )
927 ELSE
928*
929* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
930* scale = 0 and compute a solution to A**H *x = 0.
931*
932 DO 180 i = 1, n
933 x( i ) = zero
934 180 CONTINUE
935 x( j ) = one
936 scale = zero
937 xmax = zero
938 END IF
939 185 CONTINUE
940 ELSE
941*
942* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
943* product has already been divided by 1/A(j,j).
944*
945 x( j ) = cladiv( x( j ), tjjs ) - csumj
946 END IF
947 xmax = max( xmax, cabs1( x( j ) ) )
948 190 CONTINUE
949 END IF
950 scale = scale / tscal
951 END IF
952*
953* Scale the column norms by 1/TSCAL for return.
954*
955 IF( tscal.NE.one ) THEN
956 CALL sscal( n, one / tscal, cnorm, 1 )
957 END IF
958*
959 RETURN
960*
961* End of CLATRS
962*
ctrsv
subroutine ctrsv(uplo, trans, diag, n, a, lda, x, incx)
CTRSV
Definition ctrsv.f:149

◆ clauu2()

subroutine clauu2 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer info )

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

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

Purpose:
!>
!> CLAUU2 computes the product U * U**H or L**H * 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 COMPLEX 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**H;
!>          if UPLO = 'L', the lower triangle of A is overwritten with
!>          the lower triangle of the product L**H * 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 clauu2.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 COMPLEX A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 COMPLEX ONE
119 parameter( one = ( 1.0e+0, 0.0e+0 ) )
120* ..
121* .. Local Scalars ..
122 LOGICAL UPPER
123 INTEGER I
124 REAL AII
125* ..
126* .. External Functions ..
127 LOGICAL LSAME
128 COMPLEX CDOTC
129 EXTERNAL lsame, cdotc
130* ..
131* .. External Subroutines ..
132 EXTERNAL cgemv, clacgv, csscal, xerbla
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC cmplx, max, real
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( 'CLAUU2', -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**H.
163*
164 DO 10 i = 1, n
165 aii = real( a( i, i ) )
166 IF( i.LT.n ) THEN
167 a( i, i ) = aii*aii + real( cdotc( n-i, a( i, i+1 ), lda,
168 $ a( i, i+1 ), lda ) )
169 CALL clacgv( n-i, a( i, i+1 ), lda )
170 CALL cgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
171 $ lda, a( i, i+1 ), lda, cmplx( aii ),
172 $ a( 1, i ), 1 )
173 CALL clacgv( n-i, a( i, i+1 ), lda )
174 ELSE
175 CALL csscal( i, aii, a( 1, i ), 1 )
176 END IF
177 10 CONTINUE
178*
179 ELSE
180*
181* Compute the product L**H * L.
182*
183 DO 20 i = 1, n
184 aii = real( a( i, i ) )
185 IF( i.LT.n ) THEN
186 a( i, i ) = aii*aii + real( cdotc( n-i, a( i+1, i ), 1,
187 $ a( i+1, i ), 1 ) )
188 CALL clacgv( i-1, a( i, 1 ), lda )
189 CALL cgemv( 'Conjugate transpose', n-i, i-1, one,
190 $ a( i+1, 1 ), lda, a( i+1, i ), 1,
191 $ cmplx( aii ), a( i, 1 ), lda )
192 CALL clacgv( i-1, a( i, 1 ), lda )
193 ELSE
194 CALL csscal( i, aii, a( i, 1 ), lda )
195 END IF
196 20 CONTINUE
197 END IF
198*
199 RETURN
200*
201* End of CLAUU2
202*

◆ clauum()

subroutine clauum ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
integer info )

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

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

Purpose:
!>
!> CLAUUM computes the product U * U**H or L**H * 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 COMPLEX 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**H;
!>          if UPLO = 'L', the lower triangle of A is overwritten with
!>          the lower triangle of the product L**H * 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 clauum.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 COMPLEX A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 REAL ONE
119 parameter( one = 1.0e+0 )
120 COMPLEX CONE
121 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
122* ..
123* .. Local Scalars ..
124 LOGICAL UPPER
125 INTEGER I, IB, NB
126* ..
127* .. External Functions ..
128 LOGICAL LSAME
129 INTEGER ILAENV
130 EXTERNAL lsame, ilaenv
131* ..
132* .. External Subroutines ..
133 EXTERNAL cgemm, cherk, clauu2, ctrmm, xerbla
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC max, min
137* ..
138* .. Executable Statements ..
139*
140* Test the input parameters.
141*
142 info = 0
143 upper = lsame( uplo, 'U' )
144 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
145 info = -1
146 ELSE IF( n.LT.0 ) THEN
147 info = -2
148 ELSE IF( lda.LT.max( 1, n ) ) THEN
149 info = -4
150 END IF
151 IF( info.NE.0 ) THEN
152 CALL xerbla( 'CLAUUM', -info )
153 RETURN
154 END IF
155*
156* Quick return if possible
157*
158 IF( n.EQ.0 )
159 $ RETURN
160*
161* Determine the block size for this environment.
162*
163 nb = ilaenv( 1, 'CLAUUM', uplo, n, -1, -1, -1 )
164*
165 IF( nb.LE.1 .OR. nb.GE.n ) THEN
166*
167* Use unblocked code
168*
169 CALL clauu2( uplo, n, a, lda, info )
170 ELSE
171*
172* Use blocked code
173*
174 IF( upper ) THEN
175*
176* Compute the product U * U**H.
177*
178 DO 10 i = 1, n, nb
179 ib = min( nb, n-i+1 )
180 CALL ctrmm( 'Right', 'Upper', 'Conjugate transpose',
181 $ 'Non-unit', i-1, ib, cone, a( i, i ), lda,
182 $ a( 1, i ), lda )
183 CALL clauu2( 'Upper', ib, a( i, i ), lda, info )
184 IF( i+ib.LE.n ) THEN
185 CALL cgemm( 'No transpose', 'Conjugate transpose',
186 $ i-1, ib, n-i-ib+1, cone, a( 1, i+ib ),
187 $ lda, a( i, i+ib ), lda, cone, a( 1, i ),
188 $ lda )
189 CALL cherk( 'Upper', 'No transpose', ib, n-i-ib+1,
190 $ one, a( i, i+ib ), lda, one, a( i, i ),
191 $ lda )
192 END IF
193 10 CONTINUE
194 ELSE
195*
196* Compute the product L**H * L.
197*
198 DO 20 i = 1, n, nb
199 ib = min( nb, n-i+1 )
200 CALL ctrmm( 'Left', 'Lower', 'Conjugate transpose',
201 $ 'Non-unit', ib, i-1, cone, a( i, i ), lda,
202 $ a( i, 1 ), lda )
203 CALL clauu2( 'Lower', ib, a( i, i ), lda, info )
204 IF( i+ib.LE.n ) THEN
205 CALL cgemm( 'Conjugate transpose', 'No transpose', ib,
206 $ i-1, n-i-ib+1, cone, a( i+ib, i ), lda,
207 $ a( i+ib, 1 ), lda, cone, a( i, 1 ), lda )
208 CALL cherk( 'Lower', 'Conjugate transpose', ib,
209 $ n-i-ib+1, one, a( i+ib, i ), lda, one,
210 $ a( i, i ), lda )
211 END IF
212 20 CONTINUE
213 END IF
214 END IF
215*
216 RETURN
217*
218* End of CLAUUM
219*
clauu2
subroutine clauu2(uplo, n, a, lda, info)
CLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblock...
Definition clauu2.f:102
cherk
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173

◆ crot()

subroutine crot ( integer n,
complex, dimension( * ) cx,
integer incx,
complex, dimension( * ) cy,
integer incy,
real c,
complex s )

CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.

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

Purpose:
!>
!> CROT   applies a plane rotation, where the cos (C) is real and the
!> sin (S) is complex, and the vectors CX and CY are complex.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of elements in the vectors CX and CY.
!>
[in,out]CX
!>          CX is COMPLEX array, dimension (N)
!>          On input, the vector X.
!>          On output, CX is overwritten with C*X + S*Y.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between successive values of CX.  INCX <> 0.
!>
[in,out]CY
!>          CY is COMPLEX array, dimension (N)
!>          On input, the vector Y.
!>          On output, CY is overwritten with -CONJG(S)*X + C*Y.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between successive values of CY.  INCX <> 0.
!>
[in]C
!>          C is REAL
!>
[in]S
!>          S is COMPLEX
!>          C and S define a rotation
!>             [  C          S  ]
!>             [ -conjg(S)   C  ]
!>          where C*C + S*CONJG(S) = 1.0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 102 of file crot.f.

103*
104* -- LAPACK auxiliary routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 INTEGER INCX, INCY, N
110 REAL C
111 COMPLEX S
112* ..
113* .. Array Arguments ..
114 COMPLEX CX( * ), CY( * )
115* ..
116*
117* =====================================================================
118*
119* .. Local Scalars ..
120 INTEGER I, IX, IY
121 COMPLEX STEMP
122* ..
123* .. Intrinsic Functions ..
124 INTRINSIC conjg
125* ..
126* .. Executable Statements ..
127*
128 IF( n.LE.0 )
129 $ RETURN
130 IF( incx.EQ.1 .AND. incy.EQ.1 )
131 $ GO TO 20
132*
133* Code for unequal increments or equal increments not equal to 1
134*
135 ix = 1
136 iy = 1
137 IF( incx.LT.0 )
138 $ ix = ( -n+1 )*incx + 1
139 IF( incy.LT.0 )
140 $ iy = ( -n+1 )*incy + 1
141 DO 10 i = 1, n
142 stemp = c*cx( ix ) + s*cy( iy )
143 cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix )
144 cx( ix ) = stemp
145 ix = ix + incx
146 iy = iy + incy
147 10 CONTINUE
148 RETURN
149*
150* Code for both increments equal to 1
151*
152 20 CONTINUE
153 DO 30 i = 1, n
154 stemp = c*cx( i ) + s*cy( i )
155 cy( i ) = c*cy( i ) - conjg( s )*cx( i )
156 cx( i ) = stemp
157 30 CONTINUE
158 RETURN

◆ cspmv()

subroutine cspmv ( character uplo,
integer n,
complex alpha,
complex, dimension( * ) ap,
complex, dimension( * ) x,
integer incx,
complex beta,
complex, dimension( * ) y,
integer incy )

CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix

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

Purpose:
!>
!> CSPMV  performs the matrix-vector operation
!>
!>    y := alpha*A*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are n element vectors and
!> A is an n by n symmetric matrix, supplied in packed form.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the matrix A is supplied in the packed
!>           array AP as follows:
!>
!>              UPLO = 'U' or 'u'   The upper triangular part of A is
!>                                  supplied in AP.
!>
!>              UPLO = 'L' or 'l'   The lower triangular part of A is
!>                                  supplied in AP.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is COMPLEX
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]AP
!>          AP is COMPLEX array, dimension at least
!>           ( ( N*( N + 1 ) )/2 ).
!>           Before entry, with UPLO = 'U' or 'u', the array AP must
!>           contain the upper triangular part of the symmetric matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!>           and a( 2, 2 ) respectively, and so on.
!>           Before entry, with UPLO = 'L' or 'l', the array AP must
!>           contain the lower triangular part of the symmetric matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!>           and a( 3, 1 ) respectively, and so on.
!>           Unchanged on exit.
!>
[in]X
!>          X is COMPLEX array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array X must contain the N-
!>           element vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in]BETA
!>          BETA is COMPLEX
!>           On entry, BETA specifies the scalar beta. When BETA is
!>           supplied as zero then Y need not be set on input.
!>           Unchanged on exit.
!>
[in,out]Y
!>          Y is COMPLEX array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array Y must contain the n
!>           element vector y. On exit, Y is overwritten by the updated
!>           vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file cspmv.f.

151*
152* -- LAPACK auxiliary routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 CHARACTER UPLO
158 INTEGER INCX, INCY, N
159 COMPLEX ALPHA, BETA
160* ..
161* .. Array Arguments ..
162 COMPLEX AP( * ), X( * ), Y( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 COMPLEX ONE
169 parameter( one = ( 1.0e+0, 0.0e+0 ) )
170 COMPLEX ZERO
171 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
172* ..
173* .. Local Scalars ..
174 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
175 COMPLEX TEMP1, TEMP2
176* ..
177* .. External Functions ..
178 LOGICAL LSAME
179 EXTERNAL lsame
180* ..
181* .. External Subroutines ..
182 EXTERNAL xerbla
183* ..
184* .. Executable Statements ..
185*
186* Test the input parameters.
187*
188 info = 0
189 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
190 info = 1
191 ELSE IF( n.LT.0 ) THEN
192 info = 2
193 ELSE IF( incx.EQ.0 ) THEN
194 info = 6
195 ELSE IF( incy.EQ.0 ) THEN
196 info = 9
197 END IF
198 IF( info.NE.0 ) THEN
199 CALL xerbla( 'CSPMV ', info )
200 RETURN
201 END IF
202*
203* Quick return if possible.
204*
205 IF( ( n.EQ.0 ) .OR. ( ( alpha.EQ.zero ) .AND. ( beta.EQ.one ) ) )
206 $ RETURN
207*
208* Set up the start points in X and Y.
209*
210 IF( incx.GT.0 ) THEN
211 kx = 1
212 ELSE
213 kx = 1 - ( n-1 )*incx
214 END IF
215 IF( incy.GT.0 ) THEN
216 ky = 1
217 ELSE
218 ky = 1 - ( n-1 )*incy
219 END IF
220*
221* Start the operations. In this version the elements of the array AP
222* are accessed sequentially with one pass through AP.
223*
224* First form y := beta*y.
225*
226 IF( beta.NE.one ) THEN
227 IF( incy.EQ.1 ) THEN
228 IF( beta.EQ.zero ) THEN
229 DO 10 i = 1, n
230 y( i ) = zero
231 10 CONTINUE
232 ELSE
233 DO 20 i = 1, n
234 y( i ) = beta*y( i )
235 20 CONTINUE
236 END IF
237 ELSE
238 iy = ky
239 IF( beta.EQ.zero ) THEN
240 DO 30 i = 1, n
241 y( iy ) = zero
242 iy = iy + incy
243 30 CONTINUE
244 ELSE
245 DO 40 i = 1, n
246 y( iy ) = beta*y( iy )
247 iy = iy + incy
248 40 CONTINUE
249 END IF
250 END IF
251 END IF
252 IF( alpha.EQ.zero )
253 $ RETURN
254 kk = 1
255 IF( lsame( uplo, 'U' ) ) THEN
256*
257* Form y when AP contains the upper triangle.
258*
259 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
260 DO 60 j = 1, n
261 temp1 = alpha*x( j )
262 temp2 = zero
263 k = kk
264 DO 50 i = 1, j - 1
265 y( i ) = y( i ) + temp1*ap( k )
266 temp2 = temp2 + ap( k )*x( i )
267 k = k + 1
268 50 CONTINUE
269 y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2
270 kk = kk + j
271 60 CONTINUE
272 ELSE
273 jx = kx
274 jy = ky
275 DO 80 j = 1, n
276 temp1 = alpha*x( jx )
277 temp2 = zero
278 ix = kx
279 iy = ky
280 DO 70 k = kk, kk + j - 2
281 y( iy ) = y( iy ) + temp1*ap( k )
282 temp2 = temp2 + ap( k )*x( ix )
283 ix = ix + incx
284 iy = iy + incy
285 70 CONTINUE
286 y( jy ) = y( jy ) + temp1*ap( kk+j-1 ) + alpha*temp2
287 jx = jx + incx
288 jy = jy + incy
289 kk = kk + j
290 80 CONTINUE
291 END IF
292 ELSE
293*
294* Form y when AP contains the lower triangle.
295*
296 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
297 DO 100 j = 1, n
298 temp1 = alpha*x( j )
299 temp2 = zero
300 y( j ) = y( j ) + temp1*ap( kk )
301 k = kk + 1
302 DO 90 i = j + 1, n
303 y( i ) = y( i ) + temp1*ap( k )
304 temp2 = temp2 + ap( k )*x( i )
305 k = k + 1
306 90 CONTINUE
307 y( j ) = y( j ) + alpha*temp2
308 kk = kk + ( n-j+1 )
309 100 CONTINUE
310 ELSE
311 jx = kx
312 jy = ky
313 DO 120 j = 1, n
314 temp1 = alpha*x( jx )
315 temp2 = zero
316 y( jy ) = y( jy ) + temp1*ap( kk )
317 ix = jx
318 iy = jy
319 DO 110 k = kk + 1, kk + n - j
320 ix = ix + incx
321 iy = iy + incy
322 y( iy ) = y( iy ) + temp1*ap( k )
323 temp2 = temp2 + ap( k )*x( ix )
324 110 CONTINUE
325 y( jy ) = y( jy ) + alpha*temp2
326 jx = jx + incx
327 jy = jy + incy
328 kk = kk + ( n-j+1 )
329 120 CONTINUE
330 END IF
331 END IF
332*
333 RETURN
334*
335* End of CSPMV
336*

◆ cspr()

subroutine cspr ( character uplo,
integer n,
complex alpha,
complex, dimension( * ) x,
integer incx,
complex, dimension( * ) ap )

CSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.

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

Purpose:
!>
!> CSPR    performs the symmetric rank 1 operation
!>
!>    A := alpha*x*x**H + A,
!>
!> where alpha is a complex scalar, x is an n element vector and A is an
!> n by n symmetric matrix, supplied in packed form.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the matrix A is supplied in the packed
!>           array AP as follows:
!>
!>              UPLO = 'U' or 'u'   The upper triangular part of A is
!>                                  supplied in AP.
!>
!>              UPLO = 'L' or 'l'   The lower triangular part of A is
!>                                  supplied in AP.
!>
!>           Unchanged on exit.
!>
[in]N
!>          N is INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
[in]ALPHA
!>          ALPHA is COMPLEX
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]X
!>          X is COMPLEX array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array X must contain the N-
!>           element vector x.
!>           Unchanged on exit.
!>
[in]INCX
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
[in,out]AP
!>          AP is COMPLEX array, dimension at least
!>           ( ( N*( N + 1 ) )/2 ).
!>           Before entry, with  UPLO = 'U' or 'u', the array AP must
!>           contain the upper triangular part of the symmetric matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!>           and a( 2, 2 ) respectively, and so on. On exit, the array
!>           AP is overwritten by the upper triangular part of the
!>           updated matrix.
!>           Before entry, with UPLO = 'L' or 'l', the array AP must
!>           contain the lower triangular part of the symmetric matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!>           and a( 3, 1 ) respectively, and so on. On exit, the array
!>           AP is overwritten by the lower triangular part of the
!>           updated matrix.
!>           Note that the imaginary parts of the diagonal elements need
!>           not be set, they are assumed to be zero, and on exit they
!>           are set to zero.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file cspr.f.

132*
133* -- LAPACK auxiliary routine --
134* -- LAPACK is a software package provided by Univ. of Tennessee, --
135* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136*
137* .. Scalar Arguments ..
138 CHARACTER UPLO
139 INTEGER INCX, N
140 COMPLEX ALPHA
141* ..
142* .. Array Arguments ..
143 COMPLEX AP( * ), X( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 COMPLEX ZERO
150 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, INFO, IX, J, JX, K, KK, KX
154 COMPLEX TEMP
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla
162* ..
163* .. Executable Statements ..
164*
165* Test the input parameters.
166*
167 info = 0
168 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
169 info = 1
170 ELSE IF( n.LT.0 ) THEN
171 info = 2
172 ELSE IF( incx.EQ.0 ) THEN
173 info = 5
174 END IF
175 IF( info.NE.0 ) THEN
176 CALL xerbla( 'CSPR ', info )
177 RETURN
178 END IF
179*
180* Quick return if possible.
181*
182 IF( ( n.EQ.0 ) .OR. ( alpha.EQ.zero ) )
183 $ RETURN
184*
185* Set the start point in X if the increment is not unity.
186*
187 IF( incx.LE.0 ) THEN
188 kx = 1 - ( n-1 )*incx
189 ELSE IF( incx.NE.1 ) THEN
190 kx = 1
191 END IF
192*
193* Start the operations. In this version the elements of the array AP
194* are accessed sequentially with one pass through AP.
195*
196 kk = 1
197 IF( lsame( uplo, 'U' ) ) THEN
198*
199* Form A when upper triangle is stored in AP.
200*
201 IF( incx.EQ.1 ) THEN
202 DO 20 j = 1, n
203 IF( x( j ).NE.zero ) THEN
204 temp = alpha*x( j )
205 k = kk
206 DO 10 i = 1, j - 1
207 ap( k ) = ap( k ) + x( i )*temp
208 k = k + 1
209 10 CONTINUE
210 ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp
211 ELSE
212 ap( kk+j-1 ) = ap( kk+j-1 )
213 END IF
214 kk = kk + j
215 20 CONTINUE
216 ELSE
217 jx = kx
218 DO 40 j = 1, n
219 IF( x( jx ).NE.zero ) THEN
220 temp = alpha*x( jx )
221 ix = kx
222 DO 30 k = kk, kk + j - 2
223 ap( k ) = ap( k ) + x( ix )*temp
224 ix = ix + incx
225 30 CONTINUE
226 ap( kk+j-1 ) = ap( kk+j-1 ) + x( jx )*temp
227 ELSE
228 ap( kk+j-1 ) = ap( kk+j-1 )
229 END IF
230 jx = jx + incx
231 kk = kk + j
232 40 CONTINUE
233 END IF
234 ELSE
235*
236* Form A when lower triangle is stored in AP.
237*
238 IF( incx.EQ.1 ) THEN
239 DO 60 j = 1, n
240 IF( x( j ).NE.zero ) THEN
241 temp = alpha*x( j )
242 ap( kk ) = ap( kk ) + temp*x( j )
243 k = kk + 1
244 DO 50 i = j + 1, n
245 ap( k ) = ap( k ) + x( i )*temp
246 k = k + 1
247 50 CONTINUE
248 ELSE
249 ap( kk ) = ap( kk )
250 END IF
251 kk = kk + n - j + 1
252 60 CONTINUE
253 ELSE
254 jx = kx
255 DO 80 j = 1, n
256 IF( x( jx ).NE.zero ) THEN
257 temp = alpha*x( jx )
258 ap( kk ) = ap( kk ) + temp*x( jx )
259 ix = jx
260 DO 70 k = kk + 1, kk + n - j
261 ix = ix + incx
262 ap( k ) = ap( k ) + x( ix )*temp
263 70 CONTINUE
264 ELSE
265 ap( kk ) = ap( kk )
266 END IF
267 jx = jx + incx
268 kk = kk + n - j + 1
269 80 CONTINUE
270 END IF
271 END IF
272*
273 RETURN
274*
275* End of CSPR
276*

◆ csrscl()

subroutine csrscl ( integer n,
real sa,
complex, dimension( * ) sx,
integer incx )

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

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

Purpose:
!>
!> CSRSCL multiplies an n-element complex 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 REAL
!>          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 COMPLEX 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 csrscl.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 REAL SA
92* ..
93* .. Array Arguments ..
94 COMPLEX SX( * )
95* ..
96*
97* =====================================================================
98*
99* .. Parameters ..
100 REAL ZERO, ONE
101 parameter( zero = 0.0e+0, one = 1.0e+0 )
102* ..
103* .. Local Scalars ..
104 LOGICAL DONE
105 REAL BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
106* ..
107* .. External Functions ..
108 REAL SLAMCH
109 EXTERNAL slamch
110* ..
111* .. External Subroutines ..
112 EXTERNAL csscal, slabad
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 = slamch( 'S' )
127 bignum = one / smlnum
128 CALL slabad( 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 csscal( n, mul, sx, incx )
163*
164 IF( .NOT.done )
165 $ GO TO 10
166*
167 RETURN
168*
169* End of CSRSCL
170*

◆ ctprfb()

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

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

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

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

◆ icmax1()

integer function icmax1 ( integer n,
complex, dimension(*) cx,
integer incx )

ICMAX1 finds the index of the first vector element of maximum absolute value.

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

Purpose:
!>
!> ICMAX1 finds the index of the first vector element of maximum absolute value.
!>
!> Based on ICAMAX from Level 1 BLAS.
!> The change is to use the 'genuine' absolute value.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of elements in the vector CX.
!>
[in]CX
!>          CX is COMPLEX array, dimension (N)
!>          The vector CX. The ICMAX1 function returns the index of its first
!>          element of maximum absolute value.
!>
[in]INCX
!>          INCX is INTEGER
!>          The spacing between successive values of CX.  INCX >= 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Nick Higham for use with CLACON.

Definition at line 80 of file icmax1.f.

81*
82* -- LAPACK auxiliary routine --
83* -- LAPACK is a software package provided by Univ. of Tennessee, --
84* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
85*
86* .. Scalar Arguments ..
87 INTEGER INCX, N
88* ..
89* .. Array Arguments ..
90 COMPLEX CX(*)
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 REAL SMAX
97 INTEGER I, IX
98* ..
99* .. Intrinsic Functions ..
100 INTRINSIC abs
101* ..
102* .. Executable Statements ..
103*
104 icmax1 = 0
105 IF (n.LT.1 .OR. incx.LE.0) RETURN
106 icmax1 = 1
107 IF (n.EQ.1) RETURN
108 IF (incx.EQ.1) THEN
109*
110* code for increment equal to 1
111*
112 smax = abs(cx(1))
113 DO i = 2,n
114 IF (abs(cx(i)).GT.smax) THEN
115 icmax1 = i
116 smax = abs(cx(i))
117 END IF
118 END DO
119 ELSE
120*
121* code for increment not equal to 1
122*
123 ix = 1
124 smax = abs(cx(1))
125 ix = ix + incx
126 DO i = 2,n
127 IF (abs(cx(ix)).GT.smax) THEN
128 icmax1 = i
129 smax = abs(cx(ix))
130 END IF
131 ix = ix + incx
132 END DO
133 END IF
134 RETURN
135*
136* End of ICMAX1
137*

◆ ilaclc()

integer function ilaclc ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda )

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

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

Purpose:
!>
!> ILACLC scans A for its last non-zero column.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 77 of file ilaclc.f.

78*
79* -- LAPACK auxiliary routine --
80* -- LAPACK is a software package provided by Univ. of Tennessee, --
81* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
82*
83* .. Scalar Arguments ..
84 INTEGER M, N, LDA
85* ..
86* .. Array Arguments ..
87 COMPLEX A( LDA, * )
88* ..
89*
90* =====================================================================
91*
92* .. Parameters ..
93 COMPLEX ZERO
94 parameter( zero = (0.0e+0, 0.0e+0) )
95* ..
96* .. Local Scalars ..
97 INTEGER I
98* ..
99* .. Executable Statements ..
100*
101* Quick test for the common case where one corner is non-zero.
102 IF( n.EQ.0 ) THEN
103 ilaclc = n
104 ELSE IF( a(1, n).NE.zero .OR. a(m, n).NE.zero ) THEN
105 ilaclc = n
106 ELSE
107* Now scan each column from the end, returning with the first non-zero.
108 DO ilaclc = n, 1, -1
109 DO i = 1, m
110 IF( a(i, ilaclc).NE.zero ) RETURN
111 END DO
112 END DO
113 END IF
114 RETURN

◆ ilaclr()

integer function ilaclr ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda )

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

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

Purpose:
!>
!> ILACLR scans A for its last non-zero row.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.
!>
[in]A
!>          A is COMPLEX array, dimension (LDA,N)
!>          The m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 77 of file ilaclr.f.

78*
79* -- LAPACK auxiliary routine --
80* -- LAPACK is a software package provided by Univ. of Tennessee, --
81* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
82*
83* .. Scalar Arguments ..
84 INTEGER M, N, LDA
85* ..
86* .. Array Arguments ..
87 COMPLEX A( LDA, * )
88* ..
89*
90* =====================================================================
91*
92* .. Parameters ..
93 COMPLEX ZERO
94 parameter( zero = (0.0e+0, 0.0e+0) )
95* ..
96* .. Local Scalars ..
97 INTEGER I, J
98* ..
99* .. Executable Statements ..
100*
101* Quick test for the common case where one corner is non-zero.
102 IF( m.EQ.0 ) THEN
103 ilaclr = m
104 ELSE IF( a(m, 1).NE.zero .OR. a(m, n).NE.zero ) THEN
105 ilaclr = m
106 ELSE
107* Scan up each column tracking the last zero row seen.
108 ilaclr = 0
109 DO j = 1, n
110 i=m
111 DO WHILE((a(max(i,1),j).EQ.zero).AND.(i.GE.1))
112 i=i-1
113 ENDDO
114 ilaclr = max( ilaclr, i )
115 END DO
116 END IF
117 RETURN

◆ izmax1()

integer function izmax1 ( integer n,
complex*16, dimension(*) zx,
integer incx )

IZMAX1 finds the index of the first vector element of maximum absolute value.

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

Purpose:
!>
!> IZMAX1 finds the index of the first vector element of maximum absolute value.
!>
!> Based on IZAMAX from Level 1 BLAS.
!> The change is to use the 'genuine' absolute value.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of elements in the vector ZX.
!>
[in]ZX
!>          ZX is COMPLEX*16 array, dimension (N)
!>          The vector ZX. The IZMAX1 function returns the index of its first
!>          element of maximum absolute value.
!>
[in]INCX
!>          INCX is INTEGER
!>          The spacing between successive values of ZX.  INCX >= 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Nick Higham for use with ZLACON.

Definition at line 80 of file izmax1.f.

81*
82* -- LAPACK auxiliary routine --
83* -- LAPACK is a software package provided by Univ. of Tennessee, --
84* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
85*
86* .. Scalar Arguments ..
87 INTEGER INCX, N
88* ..
89* .. Array Arguments ..
90 COMPLEX*16 ZX(*)
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 DOUBLE PRECISION DMAX
97 INTEGER I, IX
98* ..
99* .. Intrinsic Functions ..
100 INTRINSIC abs
101* ..
102* .. Executable Statements ..
103*
104 izmax1 = 0
105 IF (n.LT.1 .OR. incx.LE.0) RETURN
106 izmax1 = 1
107 IF (n.EQ.1) RETURN
108 IF (incx.EQ.1) THEN
109*
110* code for increment equal to 1
111*
112 dmax = abs(zx(1))
113 DO i = 2,n
114 IF (abs(zx(i)).GT.dmax) THEN
115 izmax1 = i
116 dmax = abs(zx(i))
117 END IF
118 END DO
119 ELSE
120*
121* code for increment not equal to 1
122*
123 ix = 1
124 dmax = abs(zx(1))
125 ix = ix + incx
126 DO i = 2,n
127 IF (abs(zx(ix)).GT.dmax) THEN
128 izmax1 = i
129 dmax = abs(zx(ix))
130 END IF
131 ix = ix + incx
132 END DO
133 END IF
134 RETURN
135*
136* End of IZMAX1
137*
izmax1
integer function izmax1(n, zx, incx)
IZMAX1 finds the index of the first vector element of maximum absolute value.
Definition izmax1.f:81

◆ scsum1()

real function scsum1 ( integer n,
complex, dimension( * ) cx,
integer incx )

SCSUM1 forms the 1-norm of the complex vector using the true absolute value.

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

Purpose:
!>
!> SCSUM1 takes the sum of the absolute values of a complex
!> vector and returns a single precision result.
!>
!> Based on SCASUM from the Level 1 BLAS.
!> The change is to use the 'genuine' absolute value.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of elements in the vector CX.
!>
[in]CX
!>          CX is COMPLEX array, dimension (N)
!>          The vector whose elements will be summed.
!>
[in]INCX
!>          INCX is INTEGER
!>          The spacing between successive values of CX.  INCX > 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Contributors:
Nick Higham for use with CLACON.

Definition at line 80 of file scsum1.f.

81*
82* -- LAPACK auxiliary routine --
83* -- LAPACK is a software package provided by Univ. of Tennessee, --
84* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
85*
86* .. Scalar Arguments ..
87 INTEGER INCX, N
88* ..
89* .. Array Arguments ..
90 COMPLEX CX( * )
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 INTEGER I, NINCX
97 REAL STEMP
98* ..
99* .. Intrinsic Functions ..
100 INTRINSIC abs
101* ..
102* .. Executable Statements ..
103*
104 scsum1 = 0.0e0
105 stemp = 0.0e0
106 IF( n.LE.0 )
107 $ RETURN
108 IF( incx.EQ.1 )
109 $ GO TO 20
110*
111* CODE FOR INCREMENT NOT EQUAL TO 1
112*
113 nincx = n*incx
114 DO 10 i = 1, nincx, incx
115*
116* NEXT LINE MODIFIED.
117*
118 stemp = stemp + abs( cx( i ) )
119 10 CONTINUE
120 scsum1 = stemp
121 RETURN
122*
123* CODE FOR INCREMENT EQUAL TO 1
124*
125 20 CONTINUE
126 DO 30 i = 1, n
127*
128* NEXT LINE MODIFIED.
129*
130 stemp = stemp + abs( cx( i ) )
131 30 CONTINUE
132 scsum1 = stemp
133 RETURN
134*
135* End of SCSUM1
136*