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

Functions

subroutine clag2z (m, n, sa, ldsa, a, lda, info)
 CLAG2Z converts a complex single precision matrix to a complex double precision matrix.
subroutine zlahrd (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 ZLAHRD 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.
double precision function dzsum1 (n, cx, incx)
 DZSUM1 forms the 1-norm of the complex vector using the true absolute value.
integer function ilazlc (m, n, a, lda)
 ILAZLC scans a matrix for its last non-zero column.
integer function ilazlr (m, n, a, lda)
 ILAZLR scans a matrix for its last non-zero row.
subroutine zdrscl (n, sa, sx, incx)
 ZDRSCL multiplies a vector by the reciprocal of a real scalar.
subroutine zlabrd (m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
 ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
subroutine zlacgv (n, x, incx)
 ZLACGV conjugates a complex vector.
subroutine zlacn2 (n, v, x, est, kase, isave)
 ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine zlacon (n, v, x, est, kase)
 ZLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
subroutine zlacp2 (uplo, m, n, a, lda, b, ldb)
 ZLACP2 copies all or part of a real two-dimensional array to a complex array.
subroutine zlacpy (uplo, m, n, a, lda, b, ldb)
 ZLACPY copies all or part of one two-dimensional array to another.
subroutine zlacrm (m, n, a, lda, b, ldb, c, ldc, rwork)
 ZLACRM multiplies a complex matrix by a square real matrix.
subroutine zlacrt (n, cx, incx, cy, incy, c, s)
 ZLACRT performs a linear transformation of a pair of complex vectors.
complex *16 function zladiv (x, y)
 ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
subroutine zlaein (rightv, noinit, n, h, ldh, w, v, b, ldb, rwork, eps3, smlnum, info)
 ZLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration.
subroutine zlaev2 (a, b, c, rt1, rt2, cs1, sn1)
 ZLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
subroutine zlag2c (m, n, a, lda, sa, ldsa, info)
 ZLAG2C converts a complex double precision matrix to a complex single precision matrix.
subroutine zlags2 (upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, snv, csq, snq)
 ZLAGS2
subroutine zlagtm (trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
 ZLAGTM 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 zlahqr (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, info)
 ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
subroutine zlahr2 (n, k, nb, a, lda, tau, t, ldt, y, ldy)
 ZLAHR2 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 zlaic1 (job, j, x, sest, w, gamma, sestpr, s, c)
 ZLAIC1 applies one step of incremental condition estimation.
double precision function zlangt (norm, n, dl, d, du)
 ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general tridiagonal matrix.
double precision function zlanhb (norm, uplo, n, k, ab, ldab, work)
 ZLANHB 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.
double precision function zlanhp (norm, uplo, n, ap, work)
 ZLANHP 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.
double precision function zlanhs (norm, n, a, lda, work)
 ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of an upper Hessenberg matrix.
double precision function zlanht (norm, n, d, e)
 ZLANHT 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.
double precision function zlansb (norm, uplo, n, k, ab, ldab, work)
 ZLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.
double precision function zlansp (norm, uplo, n, ap, work)
 ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
double precision function zlantb (norm, uplo, diag, n, k, ab, ldab, work)
 ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
double precision function zlantp (norm, uplo, diag, n, ap, work)
 ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular matrix supplied in packed form.
double precision function zlantr (norm, uplo, diag, m, n, a, lda, work)
 ZLANTR 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 zlapll (n, x, incx, y, incy, ssmin)
 ZLAPLL measures the linear dependence of two vectors.
subroutine zlapmr (forwrd, m, n, x, ldx, k)
 ZLAPMR rearranges rows of a matrix as specified by a permutation vector.
subroutine zlapmt (forwrd, m, n, x, ldx, k)
 ZLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine zlaqhb (uplo, n, kd, ab, ldab, s, scond, amax, equed)
 ZLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
subroutine zlaqhp (uplo, n, ap, s, scond, amax, equed)
 ZLAQHP scales a Hermitian matrix stored in packed form.
subroutine zlaqp2 (m, n, offset, a, lda, jpvt, tau, vn1, vn2, work)
 ZLAQP2 computes a QR factorization with column pivoting of the matrix block.
subroutine zlaqps (m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, vn2, auxv, f, ldf)
 ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.
subroutine zlaqr0 (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, work, lwork, info)
 ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine zlaqr1 (n, h, ldh, s1, s2, v)
 ZLAQR1 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 zlaqr2 (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)
 ZLAQR2 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 zlaqr3 (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)
 ZLAQR3 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 zlaqr4 (wantt, wantz, n, ilo, ihi, h, ldh, w, iloz, ihiz, z, ldz, work, lwork, info)
 ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Schur decomposition.
subroutine zlaqr5 (wantt, wantz, kacc22, n, ktop, kbot, nshfts, s, h, ldh, iloz, ihiz, z, ldz, v, ldv, u, ldu, nv, wv, ldwv, nh, wh, ldwh)
 ZLAQR5 performs a single small-bulge multi-shift QR sweep.
subroutine zlaqsb (uplo, n, kd, ab, ldab, s, scond, amax, equed)
 ZLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ.
subroutine zlaqsp (uplo, n, ap, s, scond, amax, equed)
 ZLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppequ.
subroutine zlar1v (n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
 ZLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the tridiagonal matrix LDLT - λI.
subroutine zlar2v (n, x, y, z, incx, c, s, incc)
 ZLAR2V 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 zlarcm (m, n, a, lda, b, ldb, c, ldc, rwork)
 ZLARCM copies all or part of a real two-dimensional array to a complex array.
subroutine zlarf (side, m, n, v, incv, tau, c, ldc, work)
 ZLARF applies an elementary reflector to a general rectangular matrix.
subroutine zlarfb (side, trans, direct, storev, m, n, k, v, ldv, t, ldt, c, ldc, work, ldwork)
 ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix.
subroutine zlarfb_gett (ident, m, n, k, t, ldt, a, lda, b, ldb, work, ldwork)
 ZLARFB_GETT
subroutine zlarfg (n, alpha, x, incx, tau)
 ZLARFG generates an elementary reflector (Householder matrix).
subroutine zlarfgp (n, alpha, x, incx, tau)
 ZLARFGP generates an elementary reflector (Householder matrix) with non-negative beta.
subroutine zlarft (direct, storev, n, k, v, ldv, tau, t, ldt)
 ZLARFT forms the triangular factor T of a block reflector H = I - vtvH
subroutine zlarfx (side, m, n, v, tau, c, ldc, work)
 ZLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling when the reflector has order ≤ 10.
subroutine zlarfy (uplo, n, v, incv, tau, c, ldc, work)
 ZLARFY
subroutine zlargv (n, x, incx, y, incy, c, incc)
 ZLARGV generates a vector of plane rotations with real cosines and complex sines.
subroutine zlarnv (idist, iseed, n, x)
 ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine zlarrv (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)
 ZLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenvalues of L D LT.
subroutine zlartv (n, x, incx, y, incy, c, s, incc)
 ZLARTV applies a vector of plane rotations with real cosines and complex sines to the elements of a pair of vectors.
subroutine zlascl (type, kl, ku, cfrom, cto, m, n, a, lda, info)
 ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlaset (uplo, m, n, alpha, beta, a, lda)
 ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine zlasr (side, pivot, direct, m, n, c, s, a, lda)
 ZLASR applies a sequence of plane rotations to a general rectangular matrix.
subroutine zlaswp (n, a, lda, k1, k2, ipiv, incx)
 ZLASWP performs a series of row interchanges on a general rectangular matrix.
subroutine zlat2c (uplo, n, a, lda, sa, ldsa, info)
 ZLAT2C converts a double complex triangular matrix to a complex triangular matrix.
subroutine zlatbs (uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
 ZLATBS solves a triangular banded system of equations.
subroutine zlatdf (ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv)
 ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
subroutine zlatps (uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
 ZLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine zlatrd (uplo, n, nb, a, lda, e, tau, w, ldw)
 ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
subroutine zlatrs (uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
 ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
subroutine zlauu2 (uplo, n, a, lda, info)
 ZLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblocked algorithm).
subroutine zlauum (uplo, n, a, lda, info)
 ZLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (blocked algorithm).
subroutine zrot (n, cx, incx, cy, incy, c, s)
 ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
subroutine zspmv (uplo, n, alpha, ap, x, incx, beta, y, incy)
 ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
subroutine zspr (uplo, n, alpha, x, incx, ap)
 ZSPR performs the symmetrical rank-1 update of a complex symmetric packed matrix.
subroutine ztprfb (side, trans, direct, storev, m, n, k, l, v, ldv, t, ldt, a, lda, b, ldb, work, ldwork)
 ZTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex matrix, which is composed of two blocks.

Detailed Description

This is the group of complex16 other auxiliary routines

Function Documentation

◆ clag2z()

subroutine clag2z ( integer m,
integer n,
complex, dimension( ldsa, * ) sa,
integer ldsa,
complex*16, dimension( lda, * ) a,
integer lda,
integer info )

CLAG2Z converts a complex single precision matrix to a complex double precision matrix.

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

Purpose:
!>
!> CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A.
!>
!> Note that while it is possible to overflow while converting
!> from double to single, it is not possible to overflow when
!> converting from single to double.
!>
!> This is an auxiliary routine so there is no argument checking.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of lines of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]SA
!>          SA is COMPLEX array, dimension (LDSA,N)
!>          On entry, the M-by-N coefficient matrix SA.
!>
[in]LDSA
!>          LDSA is INTEGER
!>          The leading dimension of the array SA.  LDSA >= max(1,M).
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On exit, the M-by-N coefficient matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 102 of file clag2z.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 INFO, LDA, LDSA, M, N
110* ..
111* .. Array Arguments ..
112 COMPLEX SA( LDSA, * )
113 COMPLEX*16 A( LDA, * )
114* ..
115*
116* =====================================================================
117*
118* .. Local Scalars ..
119 INTEGER I, J
120* ..
121* .. Executable Statements ..
122*
123 info = 0
124 DO 20 j = 1, n
125 DO 10 i = 1, m
126 a( i, j ) = sa( i, j )
127 10 CONTINUE
128 20 CONTINUE
129 RETURN
130*
131* End of CLAG2Z
132*

◆ dzsum1()

double precision function dzsum1 ( integer n,
complex*16, dimension( * ) cx,
integer incx )

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

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

Purpose:
!>
!> DZSUM1 takes the sum of the absolute values of a complex
!> vector and returns a double precision result.
!>
!> Based on DZASUM 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*16 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 ZLACON.

Definition at line 80 of file dzsum1.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 CX( * )
91* ..
92*
93* =====================================================================
94*
95* .. Local Scalars ..
96 INTEGER I, NINCX
97 DOUBLE PRECISION STEMP
98* ..
99* .. Intrinsic Functions ..
100 INTRINSIC abs
101* ..
102* .. Executable Statements ..
103*
104 dzsum1 = 0.0d0
105 stemp = 0.0d0
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 dzsum1 = 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 dzsum1 = stemp
133 RETURN
134*
135* End of DZSUM1
136*
dzsum1
double precision function dzsum1(n, cx, incx)
DZSUM1 forms the 1-norm of the complex vector using the true absolute value.
Definition dzsum1.f:81

◆ ilazlc()

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

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

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

Purpose:
!>
!> ILAZLC 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*16 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 ilazlc.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*16 A( LDA, * )
88* ..
89*
90* =====================================================================
91*
92* .. Parameters ..
93 COMPLEX*16 ZERO
94 parameter( zero = (0.0d+0, 0.0d+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 ilazlc = n
104 ELSE IF( a(1, n).NE.zero .OR. a(m, n).NE.zero ) THEN
105 ilazlc = n
106 ELSE
107* Now scan each column from the end, returning with the first non-zero.
108 DO ilazlc = n, 1, -1
109 DO i = 1, m
110 IF( a(i, ilazlc).NE.zero ) RETURN
111 END DO
112 END DO
113 END IF
114 RETURN
ilazlc
integer function ilazlc(m, n, a, lda)
ILAZLC scans a matrix for its last non-zero column.
Definition ilazlc.f:78

◆ ilazlr()

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

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

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

Purpose:
!>
!> ILAZLR 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*16 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 ilazlr.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*16 A( LDA, * )
88* ..
89*
90* =====================================================================
91*
92* .. Parameters ..
93 COMPLEX*16 ZERO
94 parameter( zero = (0.0d+0, 0.0d+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 ilazlr = m
104 ELSE IF( a(m, 1).NE.zero .OR. a(m, n).NE.zero ) THEN
105 ilazlr = m
106 ELSE
107* Scan up each column tracking the last zero row seen.
108 ilazlr = 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 ilazlr = max( ilazlr, i )
115 END DO
116 END IF
117 RETURN
ilazlr
integer function ilazlr(m, n, a, lda)
ILAZLR scans a matrix for its last non-zero row.
Definition ilazlr.f:78
max
#define max(a, b)
Definition macros.h:21

◆ zdrscl()

subroutine zdrscl ( integer n,
double precision sa,
complex*16, dimension( * ) sx,
integer incx )

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

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

Purpose:
!>
!> ZDRSCL 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 DOUBLE PRECISION
!>          The scalar a which is used to divide each component of x.
!>          SA must be >= 0, or the subroutine will divide by zero.
!>
[in,out]SX
!>          SX is COMPLEX*16 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 zdrscl.f.

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

◆ zlabrd()

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

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

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

Purpose:
!>
!> ZLABRD 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 ZGEBRD
!>
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*16 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 DOUBLE PRECISION array, dimension (NB)
!>          The diagonal elements of the first NB rows and columns of
!>          the reduced matrix.  D(i) = A(i,i).
!>
[out]E
!>          E is DOUBLE PRECISION array, dimension (NB)
!>          The off-diagonal elements of the first NB rows and columns of
!>          the reduced matrix.
!>
[out]TAUQ
!>          TAUQ is COMPLEX*16 array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix Q. See Further Details.
!>
[out]TAUP
!>          TAUP is COMPLEX*16 array, dimension (NB)
!>          The scalar factors of the elementary reflectors which
!>          represent the unitary matrix P. See Further Details.
!>
[out]X
!>          X is COMPLEX*16 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*16 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 zlabrd.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 DOUBLE PRECISION D( * ), E( * )
222 COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
223 $ Y( LDY, * )
224* ..
225*
226* =====================================================================
227*
228* .. Parameters ..
229 COMPLEX*16 ZERO, ONE
230 parameter( zero = ( 0.0d+0, 0.0d+0 ),
231 $ one = ( 1.0d+0, 0.0d+0 ) )
232* ..
233* .. Local Scalars ..
234 INTEGER I
235 COMPLEX*16 ALPHA
236* ..
237* .. External Subroutines ..
238 EXTERNAL zgemv, zlacgv, zlarfg, zscal
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 zlacgv( i-1, y( i, 1 ), ldy )
259 CALL zgemv( 'No transpose', m-i+1, i-1, -one, a( i, 1 ),
260 $ lda, y( i, 1 ), ldy, one, a( i, i ), 1 )
261 CALL zlacgv( i-1, y( i, 1 ), ldy )
262 CALL zgemv( '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 zlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,
269 $ tauq( i ) )
270 d( i ) = dble( alpha )
271 IF( i.LT.n ) THEN
272 a( i, i ) = one
273*
274* Compute Y(i+1:n,i)
275*
276 CALL zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zscal( n-i, tauq( i ), y( i+1, i ), 1 )
291*
292* Update A(i,i+1:n)
293*
294 CALL zlacgv( n-i, a( i, i+1 ), lda )
295 CALL zlacgv( i, a( i, 1 ), lda )
296 CALL zgemv( 'No transpose', n-i, i, -one, y( i+1, 1 ),
297 $ ldy, a( i, 1 ), lda, one, a( i, i+1 ), lda )
298 CALL zlacgv( i, a( i, 1 ), lda )
299 CALL zlacgv( i-1, x( i, 1 ), ldx )
300 CALL zgemv( '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 zlacgv( 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 zlarfg( n-i, alpha, a( i, min( i+2, n ) ), lda,
309 $ taup( i ) )
310 e( i ) = dble( alpha )
311 a( i, i+1 ) = one
312*
313* Compute X(i+1:m,i)
314*
315 CALL zgemv( '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 zgemv( '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 zgemv( 'No transpose', m-i, i, -one, a( i+1, 1 ),
321 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
322 CALL zgemv( '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 zgemv( '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 zscal( m-i, taup( i ), x( i+1, i ), 1 )
327 CALL zlacgv( 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 zlacgv( n-i+1, a( i, i ), lda )
339 CALL zlacgv( i-1, a( i, 1 ), lda )
340 CALL zgemv( 'No transpose', n-i+1, i-1, -one, y( i, 1 ),
341 $ ldy, a( i, 1 ), lda, one, a( i, i ), lda )
342 CALL zlacgv( i-1, a( i, 1 ), lda )
343 CALL zlacgv( i-1, x( i, 1 ), ldx )
344 CALL zgemv( '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 zlacgv( 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 zlarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,
353 $ taup( i ) )
354 d( i ) = dble( alpha )
355 IF( i.LT.m ) THEN
356 a( i, i ) = one
357*
358* Compute X(i+1:m,i)
359*
360 CALL zgemv( '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 zgemv( '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 zgemv( '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 zgemv( 'No transpose', i-1, n-i+1, one, a( 1, i ),
368 $ lda, a( i, i ), lda, zero, x( 1, i ), 1 )
369 CALL zgemv( '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 zscal( m-i, taup( i ), x( i+1, i ), 1 )
372 CALL zlacgv( n-i+1, a( i, i ), lda )
373*
374* Update A(i+1:m,i)
375*
376 CALL zlacgv( i-1, y( i, 1 ), ldy )
377 CALL zgemv( '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 zlacgv( i-1, y( i, 1 ), ldy )
380 CALL zgemv( '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 zlarfg( m-i, alpha, a( min( i+2, m ), i ), 1,
387 $ tauq( i ) )
388 e( i ) = dble( alpha )
389 a( i+1, i ) = one
390*
391* Compute Y(i+1:n,i)
392*
393 CALL zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zscal( n-i, tauq( i ), y( i+1, i ), 1 )
408 ELSE
409 CALL zlacgv( n-i+1, a( i, i ), lda )
410 END IF
411 20 CONTINUE
412 END IF
413 RETURN
414*
415* End of ZLABRD
416*
alpha
#define alpha
Definition eval.h:35
zlarfg
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106
zlacgv
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:74
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
min
#define min(a, b)
Definition macros.h:20

◆ zlacgv()

subroutine zlacgv ( integer n,
complex*16, dimension( * ) x,
integer incx )

ZLACGV conjugates a complex vector.

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

Purpose:
!>
!> ZLACGV 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*16 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 zlacgv.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*16 X( * )
84* ..
85*
86* =====================================================================
87*
88* .. Local Scalars ..
89 INTEGER I, IOFF
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dconjg
93* ..
94* .. Executable Statements ..
95*
96 IF( incx.EQ.1 ) THEN
97 DO 10 i = 1, n
98 x( i ) = dconjg( 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 ) = dconjg( x( ioff ) )
106 ioff = ioff + incx
107 20 CONTINUE
108 END IF
109 RETURN
110*
111* End of ZLACGV
112*

◆ zlacn2()

subroutine zlacn2 ( integer n,
complex*16, dimension( * ) v,
complex*16, dimension( * ) x,
double precision est,
integer kase,
integer, dimension( 3 ) isave )

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

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

Purpose:
!>
!> ZLACN2 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*16 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*16 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 ZLACN2 must be
!>         re-called with all the other parameters unchanged.
!>
[in,out]EST
!>          EST is DOUBLE PRECISION
!>         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
!>         unchanged from the previous call to ZLACN2.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to ZLACN2, 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 ZLACN2, KASE will again be 0.
!>
[in,out]ISAVE
!>          ISAVE is INTEGER array, dimension (3)
!>         ISAVE is used to save variables between calls to ZLACN2
!>
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 ZLACON, which uses the array ISAVE
!>  in place of a SAVE statement, as follows:
!>
!>     ZLACON     ZLACN2
!>      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 zlacn2.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 DOUBLE PRECISION EST
141* ..
142* .. Array Arguments ..
143 INTEGER ISAVE( 3 )
144 COMPLEX*16 V( * ), X( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 INTEGER ITMAX
151 parameter( itmax = 5 )
152 DOUBLE PRECISION ONE, TWO
153 parameter( one = 1.0d0, two = 2.0d0 )
154 COMPLEX*16 CZERO, CONE
155 parameter( czero = ( 0.0d0, 0.0d0 ),
156 $ cone = ( 1.0d0, 0.0d0 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER I, JLAST
160 DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
161* ..
162* .. External Functions ..
163 INTEGER IZMAX1
164 DOUBLE PRECISION DLAMCH, DZSUM1
165 EXTERNAL izmax1, dlamch, dzsum1
166* ..
167* .. External Subroutines ..
168 EXTERNAL zcopy
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, dcmplx, dimag
172* ..
173* .. Executable Statements ..
174*
175 safmin = dlamch( 'Safe minimum' )
176 IF( kase.EQ.0 ) THEN
177 DO 10 i = 1, n
178 x( i ) = dcmplx( one / dble( 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 = dzsum1( n, x, 1 )
198*
199 DO 30 i = 1, n
200 absxi = abs( x( i ) )
201 IF( absxi.GT.safmin ) THEN
202 x( i ) = dcmplx( dble( x( i ) ) / absxi,
203 $ dimag( 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 ) = izmax1( 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 zcopy( n, x, 1, v, 1 )
235 estold = est
236 est = dzsum1( 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 ) = dcmplx( dble( x( i ) ) / absxi,
246 $ dimag( 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 ) = izmax1( 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 ) = dcmplx( altsgn*( one+dble( i-1 ) / dble( 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*( dzsum1( n, x, 1 ) / dble( 3*n ) )
284 IF( temp.GT.est ) THEN
285 CALL zcopy( n, x, 1, v, 1 )
286 est = temp
287 END IF
288*
289 130 CONTINUE
290 kase = 0
291 RETURN
292*
293* End of ZLACN2
294*
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
izmax1
integer function izmax1(n, zx, incx)
IZMAX1 finds the index of the first vector element of maximum absolute value.
Definition izmax1.f:81

◆ zlacon()

subroutine zlacon ( integer n,
complex*16, dimension( n ) v,
complex*16, dimension( n ) x,
double precision est,
integer kase )

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

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

Purpose:
!>
!> ZLACON 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*16 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*16 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 ZLACON must be
!>         re-called with all the other parameters unchanged.
!>
[in,out]EST
!>          EST is DOUBLE PRECISION
!>         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
!>         unchanged from the previous call to ZLACON.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!>
[in,out]KASE
!>          KASE is INTEGER
!>         On the initial call to ZLACON, 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 ZLACON, 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 zlacon.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 DOUBLE PRECISION EST
122* ..
123* .. Array Arguments ..
124 COMPLEX*16 V( N ), X( N )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 INTEGER ITMAX
131 parameter( itmax = 5 )
132 DOUBLE PRECISION ONE, TWO
133 parameter( one = 1.0d0, two = 2.0d0 )
134 COMPLEX*16 CZERO, CONE
135 parameter( czero = ( 0.0d0, 0.0d0 ),
136 $ cone = ( 1.0d0, 0.0d0 ) )
137* ..
138* .. Local Scalars ..
139 INTEGER I, ITER, J, JLAST, JUMP
140 DOUBLE PRECISION ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
141* ..
142* .. External Functions ..
143 INTEGER IZMAX1
144 DOUBLE PRECISION DLAMCH, DZSUM1
145 EXTERNAL izmax1, dlamch, dzsum1
146* ..
147* .. External Subroutines ..
148 EXTERNAL zcopy
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC abs, dble, dcmplx, dimag
152* ..
153* .. Save statement ..
154 SAVE
155* ..
156* .. Executable Statements ..
157*
158 safmin = dlamch( 'Safe minimum' )
159 IF( kase.EQ.0 ) THEN
160 DO 10 i = 1, n
161 x( i ) = dcmplx( one / dble( 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 = dzsum1( n, x, 1 )
181*
182 DO 30 i = 1, n
183 absxi = abs( x( i ) )
184 IF( absxi.GT.safmin ) THEN
185 x( i ) = dcmplx( dble( x( i ) ) / absxi,
186 $ dimag( 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 = izmax1( 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 zcopy( n, x, 1, v, 1 )
218 estold = est
219 est = dzsum1( 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 ) = dcmplx( dble( x( i ) ) / absxi,
229 $ dimag( 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 = izmax1( 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 ) = dcmplx( altsgn*( one+dble( i-1 ) / dble( 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*( dzsum1( n, x, 1 ) / dble( 3*n ) )
267 IF( temp.GT.est ) THEN
268 CALL zcopy( n, x, 1, v, 1 )
269 est = temp
270 END IF
271*
272 130 CONTINUE
273 kase = 0
274 RETURN
275*
276* End of ZLACON
277*

◆ zlacp2()

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

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

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

Purpose:
!>
!> ZLACP2 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 DOUBLE PRECISION 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*16 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 zlacp2.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 DOUBLE PRECISION A( LDA, * )
115 COMPLEX*16 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 ZLACP2
157*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53

◆ zlacpy()

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

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

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

Purpose:
!>
!> ZLACPY 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*16 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*16 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 zlacpy.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*16 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 ZLACPY
155*

◆ zlacrm()

subroutine zlacrm ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork )

ZLACRM multiplies a complex matrix by a square real matrix.

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

Purpose:
!>
!> ZLACRM 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*16 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 DOUBLE PRECISION 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*16 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 DOUBLE PRECISION 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 zlacrm.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 DOUBLE PRECISION B( LDB, * ), RWORK( * )
124 COMPLEX*16 A( LDA, * ), C( LDC, * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 DOUBLE PRECISION ONE, ZERO
131 parameter( one = 1.0d0, zero = 0.0d0 )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC dble, dcmplx, dimag
138* ..
139* .. External Subroutines ..
140 EXTERNAL dgemm
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 ) = dble( a( i, j ) )
152 10 CONTINUE
153 20 CONTINUE
154*
155 l = m*n + 1
156 CALL dgemm( '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 ) = dimag( a( i, j ) )
167 50 CONTINUE
168 60 CONTINUE
169 CALL dgemm( '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 ) = dcmplx( dble( c( i, j ) ),
174 $ rwork( l+( j-1 )*m+i-1 ) )
175 70 CONTINUE
176 80 CONTINUE
177*
178 RETURN
179*
180* End of ZLACRM
181*
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187

◆ zlacrt()

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

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

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

Purpose:
!>
!> ZLACRT 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*16 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*16 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*16
!>
[in]S
!>          S is COMPLEX*16
!>          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 zlacrt.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*16 C, S
113* ..
114* .. Array Arguments ..
115 COMPLEX*16 CX( * ), CY( * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, IX, IY
122 COMPLEX*16 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

◆ zladiv()

complex*16 function zladiv ( complex*16 x,
complex*16 y )

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

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

Purpose:
!>
!> ZLADIV := 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*16
!>
[in]Y
!>          Y is COMPLEX*16
!>          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 zladiv.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*16 X, Y
71* ..
72*
73* =====================================================================
74*
75* .. Local Scalars ..
76 DOUBLE PRECISION ZI, ZR
77* ..
78* .. External Subroutines ..
79 EXTERNAL dladiv
80* ..
81* .. Intrinsic Functions ..
82 INTRINSIC dble, dcmplx, dimag
83* ..
84* .. Executable Statements ..
85*
86 CALL dladiv( dble( x ), dimag( x ), dble( y ), dimag( y ), zr,
87 $ zi )
88 zladiv = dcmplx( zr, zi )
89*
90 RETURN
91*
92* End of ZLADIV
93*
zladiv
complex *16 function zladiv(x, y)
ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition zladiv.f:64
dladiv
subroutine dladiv(a, b, c, d, p, q)
DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
Definition dladiv.f:91

◆ zlaein()

subroutine zlaein ( logical rightv,
logical noinit,
integer n,
complex*16, dimension( ldh, * ) h,
integer ldh,
complex*16 w,
complex*16, dimension( * ) v,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision eps3,
double precision smlnum,
integer info )

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

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

Purpose:
!>
!> ZLAEIN 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*16 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*16
!>          The eigenvalue of H whose corresponding right or left
!>          eigenvector is to be computed.
!>
[in,out]V
!>          V is COMPLEX*16 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*16 array, dimension (LDB,N)
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[in]EPS3
!>          EPS3 is DOUBLE PRECISION
!>          A small machine-dependent value which is used to perturb
!>          close eigenvalues, and to replace zero pivots.
!>
[in]SMLNUM
!>          SMLNUM is DOUBLE PRECISION
!>          A machine-dependent value close to the underflow threshold.
!>
[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 zlaein.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 DOUBLE PRECISION EPS3, SMLNUM
158 COMPLEX*16 W
159* ..
160* .. Array Arguments ..
161 DOUBLE PRECISION RWORK( * )
162 COMPLEX*16 B( LDB, * ), H( LDH, * ), V( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ONE, TENTH
169 parameter( one = 1.0d+0, tenth = 1.0d-1 )
170 COMPLEX*16 ZERO
171 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 CHARACTER NORMIN, TRANS
175 INTEGER I, IERR, ITS, J
176 DOUBLE PRECISION GROWTO, NRMSML, ROOTN, RTEMP, SCALE, VNORM
177 COMPLEX*16 CDUM, EI, EJ, TEMP, X
178* ..
179* .. External Functions ..
180 INTEGER IZAMAX
181 DOUBLE PRECISION DZASUM, DZNRM2
182 COMPLEX*16 ZLADIV
183 EXTERNAL izamax, dzasum, dznrm2, zladiv
184* ..
185* .. External Subroutines ..
186 EXTERNAL zdscal, zlatrs
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC abs, dble, dimag, max, sqrt
190* ..
191* .. Statement Functions ..
192 DOUBLE PRECISION CABS1
193* ..
194* .. Statement Function definitions ..
195 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( 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( dble( 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 = dznrm2( n, v, 1 )
230 CALL zdscal( 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 = zladiv( 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 = zladiv( 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 = zladiv( 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 = zladiv( 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 zlatrs( '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 = dzasum( 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 = izamax( n, v, 1 )
345 CALL zdscal( n, one / cabs1( v( i ) ), v, 1 )
346*
347 RETURN
348*
349* End of ZLAEIN
350*
izamax
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71
zlatrs
subroutine zlatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition zlatrs.f:239
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90

◆ zlaev2()

subroutine zlaev2 ( complex*16 a,
complex*16 b,
complex*16 c,
double precision rt1,
double precision rt2,
double precision cs1,
complex*16 sn1 )

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

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

Purpose:
!>
!> ZLAEV2 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*16
!>         The (1,1) element of the 2-by-2 matrix.
!>
[in]B
!>          B is COMPLEX*16
!>         The (1,2) element and the conjugate of the (2,1) element of
!>         the 2-by-2 matrix.
!>
[in]C
!>          C is COMPLEX*16
!>         The (2,2) element of the 2-by-2 matrix.
!>
[out]RT1
!>          RT1 is DOUBLE PRECISION
!>         The eigenvalue of larger absolute value.
!>
[out]RT2
!>          RT2 is DOUBLE PRECISION
!>         The eigenvalue of smaller absolute value.
!>
[out]CS1
!>          CS1 is DOUBLE PRECISION
!>
[out]SN1
!>          SN1 is COMPLEX*16
!>         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 zlaev2.f.

121*
122* -- LAPACK auxiliary routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 DOUBLE PRECISION CS1, RT1, RT2
128 COMPLEX*16 A, B, C, SN1
129* ..
130*
131* =====================================================================
132*
133* .. Parameters ..
134 DOUBLE PRECISION ZERO
135 parameter( zero = 0.0d0 )
136 DOUBLE PRECISION ONE
137 parameter( one = 1.0d0 )
138* ..
139* .. Local Scalars ..
140 DOUBLE PRECISION T
141 COMPLEX*16 W
142* ..
143* .. External Subroutines ..
144 EXTERNAL dlaev2
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, dble, dconjg
148* ..
149* .. Executable Statements ..
150*
151 IF( abs( b ).EQ.zero ) THEN
152 w = one
153 ELSE
154 w = dconjg( b ) / abs( b )
155 END IF
156 CALL dlaev2( dble( a ), abs( b ), dble( c ), rt1, rt2, cs1, t )
157 sn1 = w*t
158 RETURN
159*
160* End of ZLAEV2
161*
dlaev2
subroutine dlaev2(a, b, c, rt1, rt2, cs1, sn1)
DLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
Definition dlaev2.f:120

◆ zlag2c()

subroutine zlag2c ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex, dimension( ldsa, * ) sa,
integer ldsa,
integer info )

ZLAG2C converts a complex double precision matrix to a complex single precision matrix.

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

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

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

◆ zlags2()

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

ZLAGS2

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

Purpose:
!>
!> ZLAGS2 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 DOUBLE PRECISION
!>
[in]A2
!>          A2 is COMPLEX*16
!>
[in]A3
!>          A3 is DOUBLE PRECISION
!>          On entry, A1, A2 and A3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix A.
!>
[in]B1
!>          B1 is DOUBLE PRECISION
!>
[in]B2
!>          B2 is COMPLEX*16
!>
[in]B3
!>          B3 is DOUBLE PRECISION
!>          On entry, B1, B2 and B3 are elements of the input 2-by-2
!>          upper (lower) triangular matrix B.
!>
[out]CSU
!>          CSU is DOUBLE PRECISION
!>
[out]SNU
!>          SNU is COMPLEX*16
!>          The desired unitary matrix U.
!>
[out]CSV
!>          CSV is DOUBLE PRECISION
!>
[out]SNV
!>          SNV is COMPLEX*16
!>          The desired unitary matrix V.
!>
[out]CSQ
!>          CSQ is DOUBLE PRECISION
!>
[out]SNQ
!>          SNQ is COMPLEX*16
!>          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 zlags2.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 DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV
166 COMPLEX*16 A2, B2, SNQ, SNU, SNV
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 DOUBLE PRECISION ZERO, ONE
173 parameter( zero = 0.0d+0, one = 1.0d+0 )
174* ..
175* .. Local Scalars ..
176 DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB12, AVB11,
177 $ AVB21, AVB22, CSL, CSR, D, FB, FC, S1, S2,
178 $ SNL, SNR, UA11R, UA22R, VB11R, VB22R
179 COMPLEX*16 B, C, D1, R, T, UA11, UA12, UA21, UA22, VB11,
180 $ VB12, VB21, VB22
181* ..
182* .. External Subroutines ..
183 EXTERNAL dlasv2, zlartg
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, dble, dcmplx, dconjg, dimag
187* ..
188* .. Statement Functions ..
189 DOUBLE PRECISION ABS1
190* ..
191* .. Statement Function definitions ..
192 abs1( t ) = abs( dble( t ) ) + abs( dimag( 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 dlasv2( 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 zlartg( -dcmplx( vb11r ), dconjg( vb12 ), csq, snq,
241 $ r )
242 ELSE IF( ( abs( vb11r )+abs1( vb12 ) ).EQ.zero ) THEN
243 CALL zlartg( -dcmplx( ua11r ), dconjg( ua12 ), csq, snq,
244 $ r )
245 ELSE IF( aua12 / ( abs( ua11r )+abs1( ua12 ) ).LE.avb12 /
246 $ ( abs( vb11r )+abs1( vb12 ) ) ) THEN
247 CALL zlartg( -dcmplx( ua11r ), dconjg( ua12 ), csq, snq,
248 $ r )
249 ELSE
250 CALL zlartg( -dcmplx( vb11r ), dconjg( 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 = -dconjg( d1 )*snl*a1
265 ua22 = -dconjg( d1 )*snl*a2 + csl*a3
266*
267 vb21 = -dconjg( d1 )*snr*b1
268 vb22 = -dconjg( 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 zlartg( -dconjg( vb21 ), dconjg( vb22 ), csq, snq,
277 $ r )
278 ELSE IF( ( abs1( vb21 )+abs( vb22 ) ).EQ.zero ) THEN
279 CALL zlartg( -dconjg( ua21 ), dconjg( ua22 ), csq, snq,
280 $ r )
281 ELSE IF( aua22 / ( abs1( ua21 )+abs1( ua22 ) ).LE.avb22 /
282 $ ( abs1( vb21 )+abs1( vb22 ) ) ) THEN
283 CALL zlartg( -dconjg( ua21 ), dconjg( ua22 ), csq, snq,
284 $ r )
285 ELSE
286 CALL zlartg( -dconjg( vb21 ), dconjg( vb22 ), csq, snq,
287 $ r )
288 END IF
289*
290 csu = snl
291 snu = d1*csl
292 csv = snr
293 snv = d1*csr
294*
295 END IF
296*
297 ELSE
298*
299* Input matrices A and B are lower triangular matrices
300*
301* Form matrix C = A*adj(B) = ( a 0 )
302* ( c d )
303*
304 a = a1*b3
305 d = a3*b1
306 c = a2*b3 - a3*b2
307 fc = abs( c )
308*
309* Transform complex 2-by-2 matrix C to real matrix by unitary
310* diagonal matrix diag(d1,1).
311*
312 d1 = one
313 IF( fc.NE.zero )
314 $ d1 = c / fc
315*
316* The SVD of real 2 by 2 triangular C
317*
318* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
319* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
320*
321 CALL dlasv2( a, fc, d, s1, s2, snr, csr, snl, csl )
322*
323 IF( abs( csr ).GE.abs( snr ) .OR. abs( csl ).GE.abs( snl ) )
324 $ THEN
325*
326* Compute the (2,1) and (2,2) elements of U**H *A and V**H *B,
327* and (2,1) element of |U|**H *|A| and |V|**H *|B|.
328*
329 ua21 = -d1*snr*a1 + csr*a2
330 ua22r = csr*a3
331*
332 vb21 = -d1*snl*b1 + csl*b2
333 vb22r = csl*b3
334*
335 aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs1( a2 )
336 avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 )
337*
338* zero (2,1) elements of U**H *A and V**H *B.
339*
340 IF( ( abs1( ua21 )+abs( ua22r ) ).EQ.zero ) THEN
341 CALL zlartg( dcmplx( vb22r ), vb21, csq, snq, r )
342 ELSE IF( ( abs1( vb21 )+abs( vb22r ) ).EQ.zero ) THEN
343 CALL zlartg( dcmplx( ua22r ), ua21, csq, snq, r )
344 ELSE IF( aua21 / ( abs1( ua21 )+abs( ua22r ) ).LE.avb21 /
345 $ ( abs1( vb21 )+abs( vb22r ) ) ) THEN
346 CALL zlartg( dcmplx( ua22r ), ua21, csq, snq, r )
347 ELSE
348 CALL zlartg( dcmplx( vb22r ), vb21, csq, snq, r )
349 END IF
350*
351 csu = csr
352 snu = -dconjg( d1 )*snr
353 csv = csl
354 snv = -dconjg( d1 )*snl
355*
356 ELSE
357*
358* Compute the (1,1) and (1,2) elements of U**H *A and V**H *B,
359* and (1,1) element of |U|**H *|A| and |V|**H *|B|.
360*
361 ua11 = csr*a1 + dconjg( d1 )*snr*a2
362 ua12 = dconjg( d1 )*snr*a3
363*
364 vb11 = csl*b1 + dconjg( d1 )*snl*b2
365 vb12 = dconjg( d1 )*snl*b3
366*
367 aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs1( a2 )
368 avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 )
369*
370* zero (1,1) elements of U**H *A and V**H *B, and then swap.
371*
372 IF( ( abs1( ua11 )+abs1( ua12 ) ).EQ.zero ) THEN
373 CALL zlartg( vb12, vb11, csq, snq, r )
374 ELSE IF( ( abs1( vb11 )+abs1( vb12 ) ).EQ.zero ) THEN
375 CALL zlartg( ua12, ua11, csq, snq, r )
376 ELSE IF( aua11 / ( abs1( ua11 )+abs1( ua12 ) ).LE.avb11 /
377 $ ( abs1( vb11 )+abs1( vb12 ) ) ) THEN
378 CALL zlartg( ua12, ua11, csq, snq, r )
379 ELSE
380 CALL zlartg( vb12, vb11, csq, snq, r )
381 END IF
382*
383 csu = snr
384 snu = dconjg( d1 )*csr
385 csv = snl
386 snv = dconjg( d1 )*csl
387*
388 END IF
389*
390 END IF
391*
392 RETURN
393*
394* End of ZLAGS2
395*
zlartg
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
Definition zlartg.f90:118
dlasv2
subroutine dlasv2(f, g, h, ssmin, ssmax, snr, csr, snl, csl)
DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
Definition dlasv2.f:138

◆ zlagtm()

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

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

Purpose:
!>
!> ZLAGTM 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 DOUBLE PRECISION
!>          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]DL
!>          DL is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of T.
!>
[in]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The diagonal elements of T.
!>
[in]DU
!>          DU is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) super-diagonal elements of T.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is COMPLEX*16 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 zlagtm.f.

145*
146* -- LAPACK auxiliary routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 CHARACTER TRANS
152 INTEGER LDB, LDX, N, NRHS
153 DOUBLE PRECISION ALPHA, BETA
154* ..
155* .. Array Arguments ..
156 COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ),
157 $ X( LDX, * )
158* ..
159*
160* =====================================================================
161*
162* .. Parameters ..
163 DOUBLE PRECISION ONE, ZERO
164 parameter( one = 1.0d+0, zero = 0.0d+0 )
165* ..
166* .. Local Scalars ..
167 INTEGER I, J
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 EXTERNAL lsame
172* ..
173* .. Intrinsic Functions ..
174 INTRINSIC dconjg
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 ) + dconjg( d( 1 ) )*x( 1, j )
241 ELSE
242 b( 1, j ) = b( 1, j ) + dconjg( d( 1 ) )*x( 1, j ) +
243 $ dconjg( dl( 1 ) )*x( 2, j )
244 b( n, j ) = b( n, j ) + dconjg( du( n-1 ) )*
245 $ x( n-1, j ) + dconjg( d( n ) )*x( n, j )
246 DO 90 i = 2, n - 1
247 b( i, j ) = b( i, j ) + dconjg( du( i-1 ) )*
248 $ x( i-1, j ) + dconjg( d( i ) )*
249 $ x( i, j ) + dconjg( 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 ) - dconjg( d( 1 ) )*x( 1, j )
299 ELSE
300 b( 1, j ) = b( 1, j ) - dconjg( d( 1 ) )*x( 1, j ) -
301 $ dconjg( dl( 1 ) )*x( 2, j )
302 b( n, j ) = b( n, j ) - dconjg( du( n-1 ) )*
303 $ x( n-1, j ) - dconjg( d( n ) )*x( n, j )
304 DO 150 i = 2, n - 1
305 b( i, j ) = b( i, j ) - dconjg( du( i-1 ) )*
306 $ x( i-1, j ) - dconjg( d( i ) )*
307 $ x( i, j ) - dconjg( 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 ZLAGTM
317*

◆ zlahqr()

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

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

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

Purpose:
!>
!>    ZLAHQR 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).
!>          ZLAHQR 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*16 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*16 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*16 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, ZLAHQR 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 ZLAHQR 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 zlahqr.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*16 H( LDH, * ), W( * ), Z( LDZ, * )
207* ..
208*
209* =========================================================
210*
211* .. Parameters ..
212 COMPLEX*16 ZERO, ONE
213 parameter( zero = ( 0.0d0, 0.0d0 ),
214 $ one = ( 1.0d0, 0.0d0 ) )
215 DOUBLE PRECISION RZERO, RONE, HALF
216 parameter( rzero = 0.0d0, rone = 1.0d0, half = 0.5d0 )
217 DOUBLE PRECISION DAT1
218 parameter( dat1 = 3.0d0 / 4.0d0 )
219 INTEGER KEXSH
220 parameter( kexsh = 10 )
221* ..
222* .. Local Scalars ..
223 COMPLEX*16 CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
224 $ V2, X, Y
225 DOUBLE PRECISION 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*16 V( 2 )
232* ..
233* .. External Functions ..
234 COMPLEX*16 ZLADIV
235 DOUBLE PRECISION DLAMCH
236 EXTERNAL zladiv, dlamch
237* ..
238* .. External Subroutines ..
239 EXTERNAL dlabad, zcopy, zlarfg, zscal
240* ..
241* .. Statement Functions ..
242 DOUBLE PRECISION CABS1
243* ..
244* .. Intrinsic Functions ..
245 INTRINSIC abs, dble, dconjg, dimag, max, min, sqrt
246* ..
247* .. Statement Function definitions ..
248 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( 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( dimag( 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 = dconjg( sc ) / abs( sc )
285 h( i, i-1 ) = abs( h( i, i-1 ) )
286 CALL zscal( jhi-i+1, sc, h( i, i ), ldh )
287 CALL zscal( min( jhi, i+1 )-jlo+1, dconjg( sc ),
288 $ h( jlo, i ), 1 )
289 IF( wantz )
290 $ CALL zscal( ihiz-iloz+1, dconjg( 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 = dlamch( 'SAFE MINIMUM' )
300 safmax = rone / safmin
301 CALL dlabad( safmin, safmax )
302 ulp = dlamch( 'PRECISION' )
303 smlnum = safmin*( dble( 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( dble( h( k-1, k-2 ) ) )
349 IF( k+1.LE.ihi )
350 $ tst = tst + abs( dble( 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( dble( 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( dble( 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( dble( 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( dble( x / sx )*dble( y )+dimag( x / sx )*
418 $ dimag( y ).LT.rzero )y = -y
419 END IF
420 t = t - u*zladiv( 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 = dble( 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 = dble( 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 = dble( 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 ZLARFG, and hence
471* after the call T2 ( = T1*V(2) ) is also real.
472*
473 IF( k.GT.m )
474 $ CALL zcopy( 2, h( k, k-1 ), 1, v, 1 )
475 CALL zlarfg( 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 = dble( 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 = dconjg( 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*dconjg( 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*dconjg( 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 )*dconjg( 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 zscal( i2-j, temp, h( j, j+1 ), ldh )
528 CALL zscal( j-i1, dconjg( temp ), h( i1, j ), 1 )
529 IF( wantz ) THEN
530 CALL zscal( nz, dconjg( temp ), z( iloz, j ),
531 $ 1 )
532 END IF
533 END IF
534 110 CONTINUE
535 END IF
536 120 CONTINUE
537*
538* Ensure that H(I,I-1) is real.
539*
540 temp = h( i, i-1 )
541 IF( dimag( temp ).NE.rzero ) THEN
542 rtemp = abs( temp )
543 h( i, i-1 ) = rtemp
544 temp = temp / rtemp
545 IF( i2.GT.i )
546 $ CALL zscal( i2-i, dconjg( temp ), h( i, i+1 ), ldh )
547 CALL zscal( i-i1, temp, h( i1, i ), 1 )
548 IF( wantz ) THEN
549 CALL zscal( nz, temp, z( iloz, i ), 1 )
550 END IF
551 END IF
552*
553 130 CONTINUE
554*
555* Failure to converge in remaining number of iterations
556*
557 info = i
558 RETURN
559*
560 140 CONTINUE
561*
562* H(I,I-1) is negligible: one eigenvalue has converged.
563*
564 w( i ) = h( i, i )
565* reset deflation counter
566 kdefl = 0
567*
568* return to start of the main loop with new value of I.
569*
570 i = l - 1
571 GO TO 30
572*
573 150 CONTINUE
574 RETURN
575*
576* End of ZLAHQR
577*

◆ zlahr2()

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

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

Purpose:
!>
!> ZLAHR2 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 ZGEHRD.
!>
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*16 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*16 array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is COMPLEX*16 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*16 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 ZLAHRD
!>  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 ZLAHRD routine. (This
!>  subroutine is not backward compatible with LAPACK-3.0's ZLAHRD.)
!>
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 zlahr2.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*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
191 $ Y( LDY, NB )
192* ..
193*
194* =====================================================================
195*
196* .. Parameters ..
197 COMPLEX*16 ZERO, ONE
198 parameter( zero = ( 0.0d+0, 0.0d+0 ),
199 $ one = ( 1.0d+0, 0.0d+0 ) )
200* ..
201* .. Local Scalars ..
202 INTEGER I
203 COMPLEX*16 EI
204* ..
205* .. External Subroutines ..
206 EXTERNAL zaxpy, zcopy, zgemm, zgemv, zlacpy,
207 $ zlarfg, zscal, ztrmm, ztrmv, zlacgv
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 zlacgv( i-1, a( k+i-1, 1 ), lda )
227 CALL zgemv( '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 zlacgv( 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 zcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
242 CALL ztrmv( '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 zgemv( '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 ztrmv( 'Upper', 'Conjugate transpose', 'NON-UNIT',
255 $ i-1, t, ldt,
256 $ t( 1, nb ), 1 )
257*
258* b2 := b2 - V2*w
259*
260 CALL zgemv( '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 ztrmv( 'Lower', 'NO TRANSPOSE',
267 $ 'UNIT', i-1,
268 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
269 CALL zaxpy( 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 zlarfg( 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 zgemv( '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 zgemv( '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 zgemv( '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 zscal( n-k, tau( i ), y( k+1, i ), 1 )
294*
295* Compute T(1:I,I)
296*
297 CALL zscal( i-1, -tau( i ), t( 1, i ), 1 )
298 CALL ztrmv( '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 zlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy )
309 CALL ztrmm( '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 zgemm( '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 ztrmm( 'RIGHT', 'Upper', 'NO TRANSPOSE',
318 $ 'NON-UNIT', k, nb,
319 $ one, t, ldt, y, ldy )
320*
321 RETURN
322*
323* End of ZLAHR2
324*
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
ztrmv
subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
ZTRMV
Definition ztrmv.f:147
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187

◆ zlahrd()

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

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

Purpose:
!>
!> This routine is deprecated and has been replaced by routine ZLAHR2.
!>
!> ZLAHRD 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*16 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*16 array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!>
[out]T
!>          T is COMPLEX*16 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*16 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 zlahrd.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*16 A( LDA, * ), T( LDT, NB ), TAU( NB ),
177 $ Y( LDY, NB )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 COMPLEX*16 ZERO, ONE
184 parameter( zero = ( 0.0d+0, 0.0d+0 ),
185 $ one = ( 1.0d+0, 0.0d+0 ) )
186* ..
187* .. Local Scalars ..
188 INTEGER I
189 COMPLEX*16 EI
190* ..
191* .. External Subroutines ..
192 EXTERNAL zaxpy, zcopy, zgemv, zlacgv, zlarfg, zscal,
193 $ ztrmv
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 zlacgv( i-1, a( k+i-1, 1 ), lda )
213 CALL zgemv( 'No transpose', n, i-1, -one, y, ldy,
214 $ a( k+i-1, 1 ), lda, one, a( 1, i ), 1 )
215 CALL zlacgv( 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 zcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 )
228 CALL ztrmv( '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 zgemv( '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 ztrmv( 'Upper', 'Conjugate transpose', 'Non-unit', i-1,
240 $ t, ldt, t( 1, nb ), 1 )
241*
242* b2 := b2 - V2*w
243*
244 CALL zgemv( '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 ztrmv( 'Lower', 'No transpose', 'Unit', i-1,
250 $ a( k+1, 1 ), lda, t( 1, nb ), 1 )
251 CALL zaxpy( 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 zlarfg( 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 zgemv( '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 zgemv( '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 zgemv( 'No transpose', n, i-1, -one, y, ldy, t( 1, i ), 1,
272 $ one, y( 1, i ), 1 )
273 CALL zscal( n, tau( i ), y( 1, i ), 1 )
274*
275* Compute T(1:i,i)
276*
277 CALL zscal( i-1, -tau( i ), t( 1, i ), 1 )
278 CALL ztrmv( '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 ZLAHRD
288*

◆ zlaic1()

subroutine zlaic1 ( integer job,
integer j,
complex*16, dimension( j ) x,
double precision sest,
complex*16, dimension( j ) w,
complex*16 gamma,
double precision sestpr,
complex*16 s,
complex*16 c )

ZLAIC1 applies one step of incremental condition estimation.

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

Purpose:
!>
!> ZLAIC1 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 ZLAIC1 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*16 array, dimension (J)
!>          The j-vector x.
!>
[in]SEST
!>          SEST is DOUBLE PRECISION
!>          Estimated singular value of j by j matrix L
!>
[in]W
!>          W is COMPLEX*16 array, dimension (J)
!>          The j-vector w.
!>
[in]GAMMA
!>          GAMMA is COMPLEX*16
!>          The diagonal element gamma.
!>
[out]SESTPR
!>          SESTPR is DOUBLE PRECISION
!>          Estimated singular value of (j+1) by (j+1) matrix Lhat.
!>
[out]S
!>          S is COMPLEX*16
!>          Sine needed in forming xhat.
!>
[out]C
!>          C is COMPLEX*16
!>          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 zlaic1.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 DOUBLE PRECISION SEST, SESTPR
143 COMPLEX*16 C, GAMMA, S
144* ..
145* .. Array Arguments ..
146 COMPLEX*16 W( J ), X( J )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 DOUBLE PRECISION ZERO, ONE, TWO
153 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
154 DOUBLE PRECISION HALF, FOUR
155 parameter( half = 0.5d0, four = 4.0d0 )
156* ..
157* .. Local Scalars ..
158 DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2,
159 $ SCL, T, TEST, TMP, ZETA1, ZETA2
160 COMPLEX*16 ALPHA, COSINE, SINE
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC abs, dconjg, max, sqrt
164* ..
165* .. External Functions ..
166 DOUBLE PRECISION DLAMCH
167 COMPLEX*16 ZDOTC
168 EXTERNAL dlamch, zdotc
169* ..
170* .. Executable Statements ..
171*
172 eps = dlamch( 'Epsilon' )
173 alpha = zdotc( 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 = dble( sqrt( s*dconjg( s )+c*dconjg( 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 = dble( c / ( b+sqrt( b*b+c ) ) )
249 ELSE
250 t = dble( sqrt( b*b+c ) - b )
251 END IF
252*
253 sine = -( alpha / absest ) / t
254 cosine = -( gamma / absest ) / ( one+t )
255 tmp = dble( sqrt( sine * dconjg( sine )
256 $ + cosine * dconjg( cosine ) ) )
257
258 s = sine / tmp
259 c = cosine / tmp
260 sestpr = sqrt( t+one )*absest
261 RETURN
262 END IF
263*
264 ELSE IF( job.EQ.2 ) THEN
265*
266* Estimating smallest singular value
267*
268* special cases
269*
270 IF( sest.EQ.zero ) THEN
271 sestpr = zero
272 IF( max( absgam, absalp ).EQ.zero ) THEN
273 sine = one
274 cosine = zero
275 ELSE
276 sine = -dconjg( gamma )
277 cosine = dconjg( alpha )
278 END IF
279 s1 = max( abs( sine ), abs( cosine ) )
280 s = sine / s1
281 c = cosine / s1
282 tmp = dble( sqrt( s*dconjg( s )+c*dconjg( c ) ) )
283 s = s / tmp
284 c = c / tmp
285 RETURN
286 ELSE IF( absgam.LE.eps*absest ) THEN
287 s = zero
288 c = one
289 sestpr = absgam
290 RETURN
291 ELSE IF( absalp.LE.eps*absest ) THEN
292 s1 = absgam
293 s2 = absest
294 IF( s1.LE.s2 ) THEN
295 s = zero
296 c = one
297 sestpr = s1
298 ELSE
299 s = one
300 c = zero
301 sestpr = s2
302 END IF
303 RETURN
304 ELSE IF( absest.LE.eps*absalp .OR. absest.LE.eps*absgam ) THEN
305 s1 = absgam
306 s2 = absalp
307 IF( s1.LE.s2 ) THEN
308 tmp = s1 / s2
309 scl = sqrt( one+tmp*tmp )
310 sestpr = absest*( tmp / scl )
311 s = -( dconjg( gamma ) / s2 ) / scl
312 c = ( dconjg( alpha ) / s2 ) / scl
313 ELSE
314 tmp = s2 / s1
315 scl = sqrt( one+tmp*tmp )
316 sestpr = absest / scl
317 s = -( dconjg( gamma ) / s1 ) / scl
318 c = ( dconjg( alpha ) / s1 ) / scl
319 END IF
320 RETURN
321 ELSE
322*
323* normal case
324*
325 zeta1 = absalp / absest
326 zeta2 = absgam / absest
327*
328 norma = max( one+zeta1*zeta1+zeta1*zeta2,
329 $ zeta1*zeta2+zeta2*zeta2 )
330*
331* See if root is closer to zero or to ONE
332*
333 test = one + two*( zeta1-zeta2 )*( zeta1+zeta2 )
334 IF( test.GE.zero ) THEN
335*
336* root is close to zero, compute directly
337*
338 b = ( zeta1*zeta1+zeta2*zeta2+one )*half
339 c = zeta2*zeta2
340 t = dble( c / ( b+sqrt( abs( b*b-c ) ) ) )
341 sine = ( alpha / absest ) / ( one-t )
342 cosine = -( gamma / absest ) / t
343 sestpr = sqrt( t+four*eps*eps*norma )*absest
344 ELSE
345*
346* root is closer to ONE, shift by that amount
347*
348 b = ( zeta2*zeta2+zeta1*zeta1-one )*half
349 c = zeta1*zeta1
350 IF( b.GE.zero ) THEN
351 t = -c / ( b+sqrt( b*b+c ) )
352 ELSE
353 t = b - sqrt( b*b+c )
354 END IF
355 sine = -( alpha / absest ) / t
356 cosine = -( gamma / absest ) / ( one+t )
357 sestpr = sqrt( one+t+four*eps*eps*norma )*absest
358 END IF
359 tmp = dble( sqrt( sine * dconjg( sine )
360 $ + cosine * dconjg( cosine ) ) )
361 s = sine / tmp
362 c = cosine / tmp
363 RETURN
364*
365 END IF
366 END IF
367 RETURN
368*
369* End of ZLAIC1
370*
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83

◆ zlangt()

double precision function zlangt ( character norm,
integer n,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) d,
complex*16, dimension( * ) du )

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

Purpose:
!>
!> ZLANGT  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
ZLANGT 
!>
!>    ZLANGT = ( 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 ZLANGT as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, ZLANGT is
!>          set to zero.
!>
[in]DL
!>          DL is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX*16 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 zlangt.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*16 D( * ), DL( * ), DU( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 DOUBLE PRECISION ONE, ZERO
123 parameter( one = 1.0d+0, zero = 0.0d+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER I
127 DOUBLE PRECISION ANORM, SCALE, SUM, TEMP
128* ..
129* .. External Functions ..
130 LOGICAL LSAME, DISNAN
131 EXTERNAL lsame, disnan
132* ..
133* .. External Subroutines ..
134 EXTERNAL zlassq
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC abs, sqrt
138* ..
139* .. Executable Statements ..
140*
141 IF( n.LE.0 ) THEN
142 anorm = zero
143 ELSE IF( lsame( norm, 'M' ) ) THEN
144*
145* Find max(abs(A(i,j))).
146*
147 anorm = abs( d( n ) )
148 DO 10 i = 1, n - 1
149 IF( anorm.LT.abs( dl( i ) ) .OR. disnan( abs( dl( i ) ) ) )
150 $ anorm = abs(dl(i))
151 IF( anorm.LT.abs( d( i ) ) .OR. disnan( abs( d( i ) ) ) )
152 $ anorm = abs(d(i))
153 IF( anorm.LT.abs( du( i ) ) .OR. disnan(abs( du( i ) ) ) )
154 $ anorm = abs(du(i))
155 10 CONTINUE
156 ELSE IF( lsame( norm, 'O' ) .OR. norm.EQ.'1' ) THEN
157*
158* Find norm1(A).
159*
160 IF( n.EQ.1 ) THEN
161 anorm = abs( d( 1 ) )
162 ELSE
163 anorm = abs( d( 1 ) )+abs( dl( 1 ) )
164 temp = abs( d( n ) )+abs( du( n-1 ) )
165 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
166 DO 20 i = 2, n - 1
167 temp = abs( d( i ) )+abs( dl( i ) )+abs( du( i-1 ) )
168 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
169 20 CONTINUE
170 END IF
171 ELSE IF( lsame( norm, 'I' ) ) THEN
172*
173* Find normI(A).
174*
175 IF( n.EQ.1 ) THEN
176 anorm = abs( d( 1 ) )
177 ELSE
178 anorm = abs( d( 1 ) )+abs( du( 1 ) )
179 temp = abs( d( n ) )+abs( dl( n-1 ) )
180 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
181 DO 30 i = 2, n - 1
182 temp = abs( d( i ) )+abs( du( i ) )+abs( dl( i-1 ) )
183 IF( anorm .LT. temp .OR. disnan( temp ) ) anorm = temp
184 30 CONTINUE
185 END IF
186 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
187*
188* Find normF(A).
189*
190 scale = zero
191 sum = one
192 CALL zlassq( n, d, 1, scale, sum )
193 IF( n.GT.1 ) THEN
194 CALL zlassq( n-1, dl, 1, scale, sum )
195 CALL zlassq( n-1, du, 1, scale, sum )
196 END IF
197 anorm = scale*sqrt( sum )
198 END IF
199*
200 zlangt = anorm
201 RETURN
202*
203* End of ZLANGT
204*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
zlassq
subroutine zlassq(n, x, incx, scl, sumsq)
ZLASSQ updates a sum of squares represented in scaled form.
Definition zlassq.f90:137
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
zlangt
double precision function zlangt(norm, n, dl, d, du)
ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlangt.f:106

◆ zlanhb()

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

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

Purpose:
!>
!> ZLANHB  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
ZLANHB 
!>
!>    ZLANHB = ( 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 ZLANHB 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, ZLANHB 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*16 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 130 of file zlanhb.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 DOUBLE PRECISION WORK( * )
143 COMPLEX*16 AB( LDAB, * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 DOUBLE PRECISION ONE, ZERO
150 parameter( one = 1.0d+0, zero = 0.0d+0 )
151* ..
152* .. Local Scalars ..
153 INTEGER I, J, L
154 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
155* ..
156* .. External Functions ..
157 LOGICAL LSAME, DISNAN
158 EXTERNAL lsame, disnan
159* ..
160* .. External Subroutines ..
161 EXTERNAL zlassq
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, dble, max, min, 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. disnan( sum ) ) VALUE = sum
180 10 CONTINUE
181 sum = abs( dble( ab( k+1, j ) ) )
182 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
183 20 CONTINUE
184 ELSE
185 DO 40 j = 1, n
186 sum = abs( dble( ab( 1, j ) ) )
187 IF( VALUE .LT. sum .OR. disnan( 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. disnan( 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( dble( ab( k+1, j ) ) )
210 60 CONTINUE
211 DO 70 i = 1, n
212 sum = work( i )
213 IF( VALUE .LT. sum .OR. disnan( 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( dble( 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. disnan( 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 zlassq( 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 zlassq( 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( dble( ab( l, j ) ).NE.zero ) THEN
256 absa = abs( dble( 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 zlanhb = VALUE
269 RETURN
270*
271* End of ZLANHB
272*
zlanhb
double precision function zlanhb(norm, uplo, n, k, ab, ldab, work)
ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhb.f:132

◆ zlanhp()

double precision function zlanhp ( character norm,
character uplo,
integer n,
complex*16, dimension( * ) ap,
double precision, dimension( * ) work )

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

Purpose:
!>
!> ZLANHP  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
ZLANHP 
!>
!>    ZLANHP = ( 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 ZLANHP 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, ZLANHP is
!>          set to zero.
!>
[in]AP
!>          AP is COMPLEX*16 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 DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file zlanhp.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 DOUBLE PRECISION WORK( * )
128 COMPLEX*16 AP( * )
129* ..
130*
131* =====================================================================
132*
133* .. Parameters ..
134 DOUBLE PRECISION ONE, ZERO
135 parameter( one = 1.0d+0, zero = 0.0d+0 )
136* ..
137* .. Local Scalars ..
138 INTEGER I, J, K
139 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
140* ..
141* .. External Functions ..
142 LOGICAL LSAME, DISNAN
143 EXTERNAL lsame, disnan
144* ..
145* .. External Subroutines ..
146 EXTERNAL zlassq
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC abs, dble, 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. disnan( sum ) ) VALUE = sum
166 10 CONTINUE
167 k = k + j
168 sum = abs( dble( ap( k ) ) )
169 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
170 20 CONTINUE
171 ELSE
172 k = 1
173 DO 40 j = 1, n
174 sum = abs( dble( ap( k ) ) )
175 IF( VALUE .LT. sum .OR. disnan( sum ) ) VALUE = sum
176 DO 30 i = k + 1, k + n - j
177 sum = abs( ap( i ) )
178 IF( VALUE .LT. sum .OR. disnan( 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( dble( 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. disnan( 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( dble( 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. disnan( sum ) ) VALUE = sum
220 100 CONTINUE
221 END IF
222 ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN
223*
224* Find normF(A).
225*
226 scale = zero
227 sum = one
228 k = 2
229 IF( lsame( uplo, 'U' ) ) THEN
230 DO 110 j = 2, n
231 CALL zlassq( 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 zlassq( 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( dble( ap( k ) ).NE.zero ) THEN
244 absa = abs( dble( 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 zlanhp = VALUE
262 RETURN
263*
264* End of ZLANHP
265*
zlanhp
double precision function zlanhp(norm, uplo, n, ap, work)
ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhp.f:117

◆ zlanhs()

double precision function zlanhs ( character norm,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) work )

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

Purpose:
!>
!> ZLANHS  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
ZLANHS 
!>
!>    ZLANHS = ( 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 ZLANHS as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, ZLANHS is
!>          set to zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The n by n upper Hessenberg matrix A; the part of A below the
!>          first sub-diagonal is not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(N,1).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zlanhs.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 DOUBLE PRECISION WORK( * )
120 COMPLEX*16 A( LDA, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 DOUBLE PRECISION ONE, ZERO
127 parameter( one = 1.0d+0, zero = 0.0d+0 )
128* ..
129* .. Local Scalars ..
130 INTEGER I, J
131 DOUBLE PRECISION SCALE, SUM, VALUE
132* ..
133* .. External Functions ..
134 LOGICAL LSAME, DISNAN
135 EXTERNAL lsame, disnan
136* ..
137* .. External Subroutines ..
138 EXTERNAL zlassq
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. disnan( 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. disnan( 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. disnan( 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 zlassq( min( n, j+1 ), a( 1, j ), 1, scale, sum )
195 90 CONTINUE
196 VALUE = scale*sqrt( sum )
197 END IF
198*
199 zlanhs = VALUE
200 RETURN
201*
202* End of ZLANHS
203*
zlanhs
double precision function zlanhs(norm, n, a, lda, work)
ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlanhs.f:109

◆ zlanht()

double precision function zlanht ( character norm,
integer n,
double precision, dimension( * ) d,
complex*16, dimension( * ) e )

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

Purpose:
!>
!> ZLANHT  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
ZLANHT 
!>
!>    ZLANHT = ( 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 ZLANHT as described
!>          above.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.  When N = 0, ZLANHT is
!>          set to zero.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of A.
!>
[in]E
!>          E is COMPLEX*16 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 zlanht.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 DOUBLE PRECISION D( * )
112 COMPLEX*16 E( * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ONE, ZERO
119 parameter( one = 1.0d+0, zero = 0.0d+0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I
123 DOUBLE PRECISION ANORM, SCALE, SUM
124* ..
125* .. External Functions ..
126 LOGICAL LSAME, DISNAN
127 EXTERNAL lsame, disnan
128* ..
129* .. External Subroutines ..
130 EXTERNAL dlassq, zlassq
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC abs, max, 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. disnan( sum ) ) anorm = sum
147 sum = abs( e( i ) )
148 IF( anorm .LT. sum .OR. disnan( 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. disnan( 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. disnan( 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 zlassq( n-1, e, 1, scale, sum )
174 sum = 2*sum
175 END IF
176 CALL dlassq( n, d, 1, scale, sum )
177 anorm = scale*sqrt( sum )
178 END IF
179*
180 zlanht = anorm
181 RETURN
182*
183* End of ZLANHT
184*
dlassq
subroutine dlassq(n, x, incx, scl, sumsq)
DLASSQ updates a sum of squares represented in scaled form.
Definition dlassq.f90:137
zlanht
double precision function zlanht(norm, n, d, e)
ZLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanht.f:101

◆ zlansb()

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

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

Purpose:
!>
!> ZLANSB  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
ZLANSB 
!>
!>    ZLANSB = ( 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 ZLANSB 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, ZLANSB 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*16 array, dimension (LDAB,N)
!>          The upper or lower triangle of the symmetric band matrix A,
!>          stored in the first K+1 rows of AB.  The j-th column of A is
!>          stored in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= K+1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 128 of file zlansb.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 DOUBLE PRECISION WORK( * )
141 COMPLEX*16 AB( LDAB, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 DOUBLE PRECISION ONE, ZERO
148 parameter( one = 1.0d+0, zero = 0.0d+0 )
149* ..
150* .. Local Scalars ..
151 INTEGER I, J, L
152 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
153* ..
154* .. External Functions ..
155 LOGICAL LSAME, DISNAN
156 EXTERNAL lsame, disnan
157* ..
158* .. External Subroutines ..
159 EXTERNAL zlassq
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. disnan( 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. disnan( 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. disnan( 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. disnan( 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 zlassq( 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 zlassq( 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 zlassq( n, ab( l, 1 ), ldab, scale, sum )
249 VALUE = scale*sqrt( sum )
250 END IF
251*
252 zlansb = VALUE
253 RETURN
254*
255* End of ZLANSB
256*
zlansb
double precision function zlansb(norm, uplo, n, k, ab, ldab, work)
ZLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansb.f:130

◆ zlansp()

double precision function zlansp ( character norm,
character uplo,
integer n,
complex*16, dimension( * ) ap,
double precision, dimension( * ) work )

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

Purpose:
!>
!> ZLANSP  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
ZLANSP 
!>
!>    ZLANSP = ( 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 ZLANSP 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, ZLANSP is
!>          set to zero.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the symmetric matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 114 of file zlansp.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 DOUBLE PRECISION WORK( * )
126 COMPLEX*16 AP( * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 DOUBLE PRECISION ONE, ZERO
133 parameter( one = 1.0d+0, zero = 0.0d+0 )
134* ..
135* .. Local Scalars ..
136 INTEGER I, J, K
137 DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
138* ..
139* .. External Functions ..
140 LOGICAL LSAME, DISNAN
141 EXTERNAL lsame, disnan
142* ..
143* .. External Subroutines ..
144 EXTERNAL zlassq
145* ..
146* .. Intrinsic Functions ..
147 INTRINSIC abs, dble, dimag, 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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 zlassq( 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 zlassq( 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( dble( ap( k ) ).NE.zero ) THEN
238 absa = abs( dble( 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( dimag( ap( k ) ).NE.zero ) THEN
247 absa = abs( dimag( 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 zlansp = VALUE
265 RETURN
266*
267* End of ZLANSP
268*
zlansp
double precision function zlansp(norm, uplo, n, ap, work)
ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansp.f:115

◆ zlantb()

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

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

Purpose:
!>
!> ZLANTB  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
ZLANTB 
!>
!>    ZLANTB = ( 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 ZLANTB 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, ZLANTB 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*16 array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first k+1 rows of AB.  The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).
!>          Note that when DIAG = 'U', the elements of the array AB
!>          corresponding to the diagonal elements of the matrix A are
!>          not referenced, but are assumed to be one.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= K+1.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file zlantb.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 DOUBLE PRECISION WORK( * )
152 COMPLEX*16 AB( LDAB, * )
153* ..
154*
155* =====================================================================
156*
157* .. Parameters ..
158 DOUBLE PRECISION ONE, ZERO
159 parameter( one = 1.0d+0, zero = 0.0d+0 )
160* ..
161* .. Local Scalars ..
162 LOGICAL UDIAG
163 INTEGER I, J, L
164 DOUBLE PRECISION SCALE, SUM, VALUE
165* ..
166* .. External Functions ..
167 LOGICAL LSAME, DISNAN
168 EXTERNAL lsame, disnan
169* ..
170* .. External Subroutines ..
171 EXTERNAL zlassq
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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlantb = VALUE
356 RETURN
357*
358* End of ZLANTB
359*
zlantb
double precision function zlantb(norm, uplo, diag, n, k, ab, ldab, work)
ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantb.f:141

◆ zlantp()

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

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

Purpose:
!>
!> ZLANTP  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
ZLANTP 
!>
!>    ZLANTP = ( 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 ZLANTP 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, ZLANTP is
!>          set to zero.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>          Note that when DIAG = 'U', the elements of the array AP
!>          corresponding to the diagonal elements of the matrix A are
!>          not referenced, but are assumed to be one.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zlantp.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 DOUBLE PRECISION WORK( * )
136 COMPLEX*16 AP( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, ZERO
143 parameter( one = 1.0d+0, zero = 0.0d+0 )
144* ..
145* .. Local Scalars ..
146 LOGICAL UDIAG
147 INTEGER I, J, K
148 DOUBLE PRECISION SCALE, SUM, VALUE
149* ..
150* .. External Functions ..
151 LOGICAL LSAME, DISNAN
152 EXTERNAL lsame, disnan
153* ..
154* .. External Subroutines ..
155 EXTERNAL zlassq
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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlantp = VALUE
350 RETURN
351*
352* End of ZLANTP
353*
zlantp
double precision function zlantp(norm, uplo, diag, n, ap, work)
ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantp.f:125

◆ zlantr()

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

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

Purpose:
!>
!> ZLANTR  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
ZLANTR 
!>
!>    ZLANTR = ( 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 ZLANTR 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, ZLANTR 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, ZLANTR is set to zero.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The trapezoidal matrix A (A is triangular if M = N).
!>          If UPLO = 'U', the leading m by n upper trapezoidal part of
!>          the array A contains the upper trapezoidal matrix, and the
!>          strictly lower triangular part of A is not referenced.
!>          If UPLO = 'L', the leading m by n lower trapezoidal part of
!>          the array A contains the lower trapezoidal matrix, and the
!>          strictly upper triangular part of A is not referenced.  Note
!>          that when DIAG = 'U', the diagonal elements of A are not
!>          referenced and are assumed to be one.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(M,1).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
!>          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file zlantr.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 DOUBLE PRECISION WORK( * )
153 COMPLEX*16 A( LDA, * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, ZERO
160 parameter( one = 1.0d+0, zero = 0.0d+0 )
161* ..
162* .. Local Scalars ..
163 LOGICAL UDIAG
164 INTEGER I, J
165 DOUBLE PRECISION SCALE, SUM, VALUE
166* ..
167* .. External Functions ..
168 LOGICAL LSAME, DISNAN
169 EXTERNAL lsame, disnan
170* ..
171* .. External Subroutines ..
172 EXTERNAL zlassq
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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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. disnan( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlassq( 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 zlantr = VALUE
348 RETURN
349*
350* End of ZLANTR
351*
zlantr
double precision function zlantr(norm, uplo, diag, m, n, a, lda, work)
ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantr.f:142

◆ zlapll()

subroutine zlapll ( integer n,
complex*16, dimension( * ) x,
integer incx,
complex*16, dimension( * ) y,
integer incy,
double precision ssmin )

ZLAPLL measures the linear dependence of two vectors.

Download ZLAPLL + 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*16 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*16 array, dimension (1+(N-1)*INCY)
!>          On entry, Y contains the N-vector Y.
!>          On exit, Y is overwritten.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between successive elements of Y. INCY > 0.
!>
[out]SSMIN
!>          SSMIN is DOUBLE PRECISION
!>          The smallest singular value of the N-by-2 matrix A = ( X Y ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 99 of file zlapll.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 DOUBLE PRECISION SSMIN
108* ..
109* .. Array Arguments ..
110 COMPLEX*16 X( * ), Y( * )
111* ..
112*
113* =====================================================================
114*
115* .. Parameters ..
116 DOUBLE PRECISION ZERO
117 parameter( zero = 0.0d+0 )
118 COMPLEX*16 CONE
119 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
120* ..
121* .. Local Scalars ..
122 DOUBLE PRECISION SSMAX
123 COMPLEX*16 A11, A12, A22, C, TAU
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC abs, dconjg
127* ..
128* .. External Functions ..
129 COMPLEX*16 ZDOTC
130 EXTERNAL zdotc
131* ..
132* .. External Subroutines ..
133 EXTERNAL dlas2, zaxpy, zlarfg
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 zlarfg( n, x( 1 ), x( 1+incx ), incx, tau )
147 a11 = x( 1 )
148 x( 1 ) = cone
149*
150 c = -dconjg( tau )*zdotc( n, x, incx, y, incy )
151 CALL zaxpy( n, c, x, incx, y, incy )
152*
153 CALL zlarfg( 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 dlas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax )
161*
162 RETURN
163*
164* End of ZLAPLL
165*
dlas2
subroutine dlas2(f, g, h, ssmin, ssmax)
DLAS2 computes singular values of a 2-by-2 triangular matrix.
Definition dlas2.f:107

◆ zlapmr()

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

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

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

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

◆ zlapmt()

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

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

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

Purpose:
!>
!> ZLAPMT 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*16 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 zlapmt.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*16 X( LDX, * )
116* ..
117*
118* =====================================================================
119*
120* .. Local Scalars ..
121 INTEGER I, II, IN, J
122 COMPLEX*16 TEMP
123* ..
124* .. Executable Statements ..
125*
126 IF( n.LE.1 )
127 $ RETURN
128*
129 DO 10 i = 1, n
130 k( i ) = -k( i )
131 10 CONTINUE
132*
133 IF( forwrd ) THEN
134*
135* Forward permutation
136*
137 DO 50 i = 1, n
138*
139 IF( k( i ).GT.0 )
140 $ GO TO 40
141*
142 j = i
143 k( j ) = -k( j )
144 in = k( j )
145*
146 20 CONTINUE
147 IF( k( in ).GT.0 )
148 $ GO TO 40
149*
150 DO 30 ii = 1, m
151 temp = x( ii, j )
152 x( ii, j ) = x( ii, in )
153 x( ii, in ) = temp
154 30 CONTINUE
155*
156 k( in ) = -k( in )
157 j = in
158 in = k( in )
159 GO TO 20
160*
161 40 CONTINUE
162*
163 50 CONTINUE
164*
165 ELSE
166*
167* Backward permutation
168*
169 DO 90 i = 1, n
170*
171 IF( k( i ).GT.0 )
172 $ GO TO 80
173*
174 k( i ) = -k( i )
175 j = k( i )
176 60 CONTINUE
177 IF( j.EQ.i )
178 $ GO TO 80
179*
180 DO 70 ii = 1, m
181 temp = x( ii, i )
182 x( ii, i ) = x( ii, j )
183 x( ii, j ) = temp
184 70 CONTINUE
185*
186 k( j ) = -k( j )
187 j = k( j )
188 GO TO 60
189*
190 80 CONTINUE
191*
192 90 CONTINUE
193*
194 END IF
195*
196 RETURN
197*
198* End of ZLAPMT
199*

◆ zlaqhb()

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

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

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

Purpose:
!>
!> ZLAQHB equilibrates a 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*16 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 DOUBLE PRECISION array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is DOUBLE PRECISION
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix entry.
!>
[out]EQUED
!>          EQUED is CHARACTER*1
!>          Specifies whether or not equilibration was done.
!>          = 'N':  No equilibration.
!>          = 'Y':  Equilibration was done, i.e., A has been replaced by
!>                  diag(S) * A * diag(S).
!>
Internal Parameters:
!>  THRESH is a threshold value used to decide if scaling should be done
!>  based on the ratio of the scaling factors.  If SCOND < THRESH,
!>  scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if scaling should
!>  be done based on the absolute size of the largest matrix element.
!>  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file zlaqhb.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 DOUBLE PRECISION AMAX, SCOND
150* ..
151* .. Array Arguments ..
152 DOUBLE PRECISION S( * )
153 COMPLEX*16 AB( LDAB, * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, THRESH
160 parameter( one = 1.0d+0, thresh = 0.1d+0 )
161* ..
162* .. Local Scalars ..
163 INTEGER I, J
164 DOUBLE PRECISION CJ, LARGE, SMALL
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 DOUBLE PRECISION DLAMCH
169 EXTERNAL lsame, dlamch
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC dble, 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 = dlamch( 'Safe minimum' ) / dlamch( '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*dble( 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*dble( 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 ZLAQHB
226*

◆ zlaqhp()

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

ZLAQHP scales a Hermitian matrix stored in packed form.

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

Purpose:
!>
!> ZLAQHP 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*16 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 DOUBLE PRECISION array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is DOUBLE PRECISION
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix entry.
!>
[out]EQUED
!>          EQUED is CHARACTER*1
!>          Specifies whether or not equilibration was done.
!>          = 'N':  No equilibration.
!>          = 'Y':  Equilibration was done, i.e., A has been replaced by
!>                  diag(S) * A * diag(S).
!>
Internal Parameters:
!>  THRESH is a threshold value used to decide if scaling should be done
!>  based on the ratio of the scaling factors.  If SCOND < THRESH,
!>  scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if scaling should
!>  be done based on the absolute size of the largest matrix element.
!>  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file zlaqhp.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 DOUBLE PRECISION AMAX, SCOND
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION S( * )
138 COMPLEX*16 AP( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ONE, THRESH
145 parameter( one = 1.0d+0, thresh = 0.1d+0 )
146* ..
147* .. Local Scalars ..
148 INTEGER I, J, JC
149 DOUBLE PRECISION CJ, LARGE, SMALL
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 DOUBLE PRECISION DLAMCH
154 EXTERNAL lsame, dlamch
155* ..
156* .. Intrinsic Functions ..
157 INTRINSIC dble
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 = dlamch( 'Safe minimum' ) / dlamch( '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*dble( 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*dble( 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 ZLAQHP
215*
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ zlaqp2()

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

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

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

Purpose:
!>
!> ZLAQP2 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*16 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*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the exact column norms.
!>
[out]WORK
!>          WORK is COMPLEX*16 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 zlaqp2.f.

149*
150* -- LAPACK auxiliary routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER LDA, M, N, OFFSET
156* ..
157* .. Array Arguments ..
158 INTEGER JPVT( * )
159 DOUBLE PRECISION VN1( * ), VN2( * )
160 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO, ONE
167 COMPLEX*16 CONE
168 parameter( zero = 0.0d+0, one = 1.0d+0,
169 $ cone = ( 1.0d+0, 0.0d+0 ) )
170* ..
171* .. Local Scalars ..
172 INTEGER I, ITEMP, J, MN, OFFPI, PVT
173 DOUBLE PRECISION TEMP, TEMP2, TOL3Z
174 COMPLEX*16 AII
175* ..
176* .. External Subroutines ..
177 EXTERNAL zlarf, zlarfg, zswap
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC abs, dconjg, max, min, sqrt
181* ..
182* .. External Functions ..
183 INTEGER IDAMAX
184 DOUBLE PRECISION DLAMCH, DZNRM2
185 EXTERNAL idamax, dlamch, dznrm2
186* ..
187* .. Executable Statements ..
188*
189 mn = min( m-offset, n )
190 tol3z = sqrt(dlamch('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 ) + idamax( n-i+1, vn1( i ), 1 )
201*
202 IF( pvt.NE.i ) THEN
203 CALL zswap( 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 zlarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1,
215 $ tau( i ) )
216 ELSE
217 CALL zlarfg( 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 zlarf( 'Left', m-offpi+1, n-i, a( offpi, i ), 1,
227 $ dconjg( 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 ) = dznrm2( 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 ZLAQP2
262*
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
zlarf
subroutine zlarf(side, m, n, v, incv, tau, c, ldc, work)
ZLARF applies an elementary reflector to a general rectangular matrix.
Definition zlarf.f:128
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81

◆ zlaqps()

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

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

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

Purpose:
!>
!> ZLAQPS 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*16 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*16 array, dimension (KB)
!>          The scalar factors of the elementary reflectors.
!>
[in,out]VN1
!>          VN1 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the partial column norms.
!>
[in,out]VN2
!>          VN2 is DOUBLE PRECISION array, dimension (N)
!>          The vector with the exact column norms.
!>
[in,out]AUXV
!>          AUXV is COMPLEX*16 array, dimension (NB)
!>          Auxiliary vector.
!>
[in,out]F
!>          F is COMPLEX*16 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 175 of file zlaqps.f.

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

◆ zlaqr0()

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

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

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

Purpose:
!>
!>    ZLAQR0 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 ZGEBAL, and then passed to ZGEHRD when the
!>           matrix output by ZGEBAL 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*16 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*16 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*16 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*16 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 ZLAQR0 does a workspace query.
!>           In this case, ZLAQR0 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, ZLAQR0 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 239 of file zlaqr0.f.

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

◆ zlaqr1()

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

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

Purpose:
!>
!>      Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 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*16 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*16
!>
[in]S2
!>          S2 is COMPLEX*16
!>
!>          S1 and S2 are the shifts defining K in (*) above.
!>
[out]V
!>          V is COMPLEX*16 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 zlaqr1.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*16 S1, S2
114 INTEGER LDH, N
115* ..
116* .. Array Arguments ..
117 COMPLEX*16 H( LDH, * ), V( * )
118* ..
119*
120* ================================================================
121*
122* .. Parameters ..
123 COMPLEX*16 ZERO
124 parameter( zero = ( 0.0d0, 0.0d0 ) )
125 DOUBLE PRECISION RZERO
126 parameter( rzero = 0.0d0 )
127* ..
128* .. Local Scalars ..
129 COMPLEX*16 CDUM, H21S, H31S
130 DOUBLE PRECISION S
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC abs, dble, dimag
134* ..
135* .. Statement Functions ..
136 DOUBLE PRECISION CABS1
137* ..
138* .. Statement Function definitions ..
139 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( 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

◆ zlaqr2()

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

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

Purpose:
!>
!>    ZLAQR2 is identical to ZLAQR3 except that it avoids
!>    recursion by calling ZLAHQR instead of ZLAQR4.
!>
!>    Aggressive early deflation:
!>
!>    ZLAQR2 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*16 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*16 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*16 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*16 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*16 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*16 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*16 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; ZLAQR2
!>          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 267 of file zlaqr2.f.

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

◆ zlaqr3()

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

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

Purpose:
!>
!>    Aggressive early deflation:
!>
!>    ZLAQR3 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*16 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*16 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*16 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*16 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*16 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*16 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*16 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; ZLAQR3
!>          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 264 of file zlaqr3.f.

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

◆ zlaqr4()

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

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

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

Purpose:
!>
!>    ZLAQR4 implements one level of recursion for ZLAQR0.
!>    It is a complete implementation of the small bulge multi-shift
!>    QR algorithm.  It may be called by ZLAQR0 and, for large enough
!>    deflation window size, it may be called by ZLAQR3.  This
!>    subroutine is identical to ZLAQR0 except that it calls ZLAQR2
!>    instead of ZLAQR3.
!>
!>    ZLAQR4 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 ZGEBAL, and then passed to ZGEHRD when the
!>           matrix output by ZGEBAL 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*16 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*16 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*16 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*16 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 ZLAQR4 does a workspace query.
!>           In this case, ZLAQR4 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, ZLAQR4 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 245 of file zlaqr4.f.

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

◆ zlaqr5()

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

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

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

Purpose:
!>
!>    ZLAQR5, called by ZLAQR0, 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: ZLAQR5 does not accumulate reflections and does not
!>             use matrix-matrix multiply to update far-from-diagonal
!>             matrix entries.
!>        = 1: ZLAQR5 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*16 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*16 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*16 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*16 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*16 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*16 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*16 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 zlaqr5.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*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
270 $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
271* ..
272*
273* ================================================================
274* .. Parameters ..
275 COMPLEX*16 ZERO, ONE
276 parameter( zero = ( 0.0d0, 0.0d0 ),
277 $ one = ( 1.0d0, 0.0d0 ) )
278 DOUBLE PRECISION RZERO, RONE
279 parameter( rzero = 0.0d0, rone = 1.0d0 )
280* ..
281* .. Local Scalars ..
282 COMPLEX*16 ALPHA, BETA, CDUM, REFSUM
283 DOUBLE PRECISION 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 DOUBLE PRECISION DLAMCH
293 EXTERNAL dlamch
294* ..
295* .. Intrinsic Functions ..
296*
297 INTRINSIC abs, dble, dconjg, dimag, max, min, mod
298* ..
299* .. Local Arrays ..
300 COMPLEX*16 VT( 3 )
301* ..
302* .. External Subroutines ..
303 EXTERNAL dlabad, zgemm, zlacpy, zlaqr1, zlarfg, zlaset,
304 $ ztrmm
305* ..
306* .. Statement Functions ..
307 DOUBLE PRECISION CABS1
308* ..
309* .. Statement Function definitions ..
310 cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( 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 = dlamch( 'SAFE MINIMUM' )
333 safmax = rone / safmin
334 CALL dlabad( safmin, safmax )
335 ulp = dlamch( 'PRECISION' )
336 smlnum = safmin*( dble( 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 zlaset( '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 zlaqr1( 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 zlarfg( 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 zlarfg( 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*dconjg( 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 = dconjg( v( 1, m22 ) )*
447 $ ( h( k+1, j )+dconjg( 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*dconjg( 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*dconjg( 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 zlaqr1( 3, h( ktop, ktop ), ldh, s( 2*m-1 ),
526 $ s( 2*m ), v( 1, m ) )
527 alpha = v( 1, m )
528 CALL zlarfg( 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*dconjg( v( 2, m ) )
538 h( k+3, k+2 ) = h( k+3, k+2 ) -
539 $ refsum*dconjg( 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 zlarfg( 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 zlaqr1( 3, h( k+1, k+1 ), ldh, s( 2*m-1 ),
571 $ s( 2*m ), vt )
572 alpha = vt( 1 )
573 CALL zlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) )
574 refsum = dconjg( vt( 1 ) )*
575 $ ( h( k+1, k )+dconjg( 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*dconjg( v( 2, m ) )
619 h( j, k+3 ) = h( j, k+3 ) -
620 $ refsum*dconjg( v( 3, m ) )
621 70 CONTINUE
622*
623* ==== Perform update from left for subsequent
624* . column. ====
625*
626 refsum = dconjg( v( 1, m ) )*( h( k+1, k+1 )
627 $ +dconjg( v( 2, m ) )*h( k+2, k+1 )
628 $ +dconjg( 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 = dconjg( v( 1, m ) )*
693 $ ( h( k+1, j )+dconjg( v( 2, m ) )*
694 $ h( k+2, j )+dconjg( 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*dconjg( v( 2, m ) )
721 u( j, kms+3 ) = u( j, kms+3 ) -
722 $ refsum*dconjg( 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*dconjg( v( 2, m ) )
739 z( j, k+3 ) = z( j, k+3 ) -
740 $ refsum*dconjg( 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 zgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),
769 $ ldu, h( incol+k1, jcol ), ldh, zero, wh,
770 $ ldwh )
771 CALL zlacpy( '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 zgemm( 'N', 'N', jlen, nu, nu, one,
780 $ h( jrow, incol+k1 ), ldh, u( k1, k1 ),
781 $ ldu, zero, wv, ldwv )
782 CALL zlacpy( '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 zgemm( 'N', 'N', jlen, nu, nu, one,
792 $ z( jrow, incol+k1 ), ldz, u( k1, k1 ),
793 $ ldu, zero, wv, ldwv )
794 CALL zlacpy( '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 ZLAQR5 ====
802*
zlaqr1
subroutine zlaqr1(n, h, ldh, s1, s2, v)
ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H and spe...
Definition zlaqr1.f:107

◆ zlaqsb()

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

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

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

Purpose:
!>
!> ZLAQSB 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*16 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 DOUBLE PRECISION array, dimension (N)
!>          The scale factors for A.
!>
[in]SCOND
!>          SCOND is DOUBLE PRECISION
!>          Ratio of the smallest S(i) to the largest S(i).
!>
[in]AMAX
!>          AMAX is DOUBLE PRECISION
!>          Absolute value of largest matrix entry.
!>
[out]EQUED
!>          EQUED is CHARACTER*1
!>          Specifies whether or not equilibration was done.
!>          = 'N':  No equilibration.
!>          = 'Y':  Equilibration was done, i.e., A has been replaced by
!>                  diag(S) * A * diag(S).
!>
Internal Parameters:
!>  THRESH is a threshold value used to decide if scaling should be done
!>  based on the ratio of the scaling factors.  If SCOND < THRESH,
!>  scaling is done.
!>
!>  LARGE and SMALL are threshold values used to decide if scaling should
!>  be done based on the absolute size of the largest matrix element.
!>  If AMAX > LARGE or AMAX < SMALL, scaling is done.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file zlaqsb.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 DOUBLE PRECISION AMAX, SCOND
150* ..
151* .. Array Arguments ..
152 DOUBLE PRECISION S( * )
153 COMPLEX*16 AB( LDAB, * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, THRESH
160 parameter( one = 1.0d+0, thresh = 0.1d+0 )
161* ..
162* .. Local Scalars ..
163 INTEGER I, J
164 DOUBLE PRECISION CJ, LARGE, SMALL
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 DOUBLE PRECISION DLAMCH
169 EXTERNAL lsame, dlamch
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 = dlamch( 'Safe minimum' ) / dlamch( '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 ZLAQSB
224*

◆ zlaqsp()

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

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

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

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

Definition at line 125 of file zlaqsp.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 DOUBLE PRECISION AMAX, SCOND
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION S( * )
138 COMPLEX*16 AP( * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ONE, THRESH
145 parameter( one = 1.0d+0, thresh = 0.1d+0 )
146* ..
147* .. Local Scalars ..
148 INTEGER I, J, JC
149 DOUBLE PRECISION CJ, LARGE, SMALL
150* ..
151* .. External Functions ..
152 LOGICAL LSAME
153 DOUBLE PRECISION DLAMCH
154 EXTERNAL lsame, dlamch
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 = dlamch( 'Safe minimum' ) / dlamch( '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 ZLAQSP
210*

◆ zlar1v()

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

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

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

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

Definition at line 227 of file zlar1v.f.

230*
231* -- LAPACK auxiliary routine --
232* -- LAPACK is a software package provided by Univ. of Tennessee, --
233* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
234*
235* .. Scalar Arguments ..
236 LOGICAL WANTNC
237 INTEGER B1, BN, N, NEGCNT, R
238 DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
239 $ RQCORR, ZTZ
240* ..
241* .. Array Arguments ..
242 INTEGER ISUPPZ( * )
243 DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
244 $ WORK( * )
245 COMPLEX*16 Z( * )
246* ..
247*
248* =====================================================================
249*
250* .. Parameters ..
251 DOUBLE PRECISION ZERO, ONE
252 parameter( zero = 0.0d0, one = 1.0d0 )
253 COMPLEX*16 CONE
254 parameter( cone = ( 1.0d0, 0.0d0 ) )
255
256* ..
257* .. Local Scalars ..
258 LOGICAL SAWNAN1, SAWNAN2
259 INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
260 $ R2
261 DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
262* ..
263* .. External Functions ..
264 LOGICAL DISNAN
265 DOUBLE PRECISION DLAMCH
266 EXTERNAL disnan, dlamch
267* ..
268* .. Intrinsic Functions ..
269 INTRINSIC abs, dble
270* ..
271* .. Executable Statements ..
272*
273 eps = dlamch( '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 = disnan( 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 = disnan( 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 = disnan( 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 + dble( 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 + dble( 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 + dble( 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 + dble( 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 ZLAR1V
484*

◆ zlar2v()

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

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

Purpose:
!>
!> ZLAR2V 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*16 array, dimension (1+(N-1)*INCX)
!>          The vector x; the elements of x are assumed to be real.
!>
[in,out]Y
!>          Y is COMPLEX*16 array, dimension (1+(N-1)*INCX)
!>          The vector y; the elements of y are assumed to be real.
!>
[in,out]Z
!>          Z is COMPLEX*16 array, dimension (1+(N-1)*INCX)
!>          The vector z.
!>
[in]INCX
!>          INCX is INTEGER
!>          The increment between elements of X, Y and Z. INCX > 0.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is COMPLEX*16 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 zlar2v.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 DOUBLE PRECISION C( * )
121 COMPLEX*16 S( * ), X( * ), Y( * ), Z( * )
122* ..
123*
124* =====================================================================
125*
126* .. Local Scalars ..
127 INTEGER I, IC, IX
128 DOUBLE PRECISION CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,
129 $ ZIR
130 COMPLEX*16 SI, T2, T3, T4, ZI
131* ..
132* .. Intrinsic Functions ..
133 INTRINSIC dble, dcmplx, dconjg, dimag
134* ..
135* .. Executable Statements ..
136*
137 ix = 1
138 ic = 1
139 DO 10 i = 1, n
140 xi = dble( x( ix ) )
141 yi = dble( y( ix ) )
142 zi = z( ix )
143 zir = dble( zi )
144 zii = dimag( zi )
145 ci = c( ic )
146 si = s( ic )
147 sir = dble( si )
148 sii = dimag( si )
149 t1r = sir*zir - sii*zii
150 t1i = sir*zii + sii*zir
151 t2 = ci*zi
152 t3 = t2 - dconjg( si )*xi
153 t4 = dconjg( t2 ) + si*yi
154 t5 = ci*xi + t1r
155 t6 = ci*yi - t1r
156 x( ix ) = ci*t5 + ( sir*dble( t4 )+sii*dimag( t4 ) )
157 y( ix ) = ci*t6 - ( sir*dble( t3 )-sii*dimag( t3 ) )
158 z( ix ) = ci*t3 + dconjg( si )*dcmplx( t6, t1i )
159 ix = ix + incx
160 ic = ic + incc
161 10 CONTINUE
162 RETURN
163*
164* End of ZLAR2V
165*

◆ zlarcm()

subroutine zlarcm ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork )

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

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

Purpose:
!>
!> ZLARCM 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 DOUBLE PRECISION 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*16 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*16 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 DOUBLE PRECISION 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 zlarcm.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 DOUBLE PRECISION A( LDA, * ), RWORK( * )
124 COMPLEX*16 B( LDB, * ), C( LDC, * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 DOUBLE PRECISION ONE, ZERO
131 parameter( one = 1.0d0, zero = 0.0d0 )
132* ..
133* .. Local Scalars ..
134 INTEGER I, J, L
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC dble, dcmplx, dimag
138* ..
139* .. External Subroutines ..
140 EXTERNAL dgemm
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 ) = dble( b( i, j ) )
152 10 CONTINUE
153 20 CONTINUE
154*
155 l = m*n + 1
156 CALL dgemm( '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 ) = dimag( b( i, j ) )
167 50 CONTINUE
168 60 CONTINUE
169 CALL dgemm( '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 ) = dcmplx( dble( c( i, j ) ),
174 $ rwork( l+( j-1 )*m+i-1 ) )
175 70 CONTINUE
176 80 CONTINUE
177*
178 RETURN
179*
180* End of ZLARCM
181*

◆ zlarf()

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

ZLARF applies an elementary reflector to a general rectangular matrix.

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

Purpose:
!>
!> ZLARF 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, 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*16 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*16
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is COMPLEX*16 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*16 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 zlarf.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*16 TAU
137* ..
138* .. Array Arguments ..
139 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 COMPLEX*16 ONE, ZERO
146 parameter( one = ( 1.0d+0, 0.0d+0 ),
147 $ zero = ( 0.0d+0, 0.0d+0 ) )
148* ..
149* .. Local Scalars ..
150 LOGICAL APPLYLEFT
151 INTEGER I, LASTV, LASTC
152* ..
153* .. External Subroutines ..
154 EXTERNAL zgemv, zgerc
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 INTEGER ILAZLR, ILAZLC
159 EXTERNAL lsame, ilazlr, ilazlc
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 = ilazlc(lastv, n, c, ldc)
187 ELSE
188* Scan for the last non-zero row in C(:,1:lastv).
189 lastc = ilazlr(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 zgemv( '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 zgerc( 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 zgemv( '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 zgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc )
223 END IF
224 END IF
225 RETURN
226*
227* End of ZLARF
228*
zgerc
subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
ZGERC
Definition zgerc.f:130

◆ zlarfb()

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

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

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

Purpose:
!>
!> ZLARFB 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*16 array, dimension
!>                                (LDV,K) if STOREV = 'C'
!>                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
!>                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
!>          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*16 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*16 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*16 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 zlarfb.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*16 C( LDC, * ), T( LDT, * ), V( LDV, * ),
208 $ WORK( LDWORK, * )
209* ..
210*
211* =====================================================================
212*
213* .. Parameters ..
214 COMPLEX*16 ONE
215 parameter( one = ( 1.0d+0, 0.0d+0 ) )
216* ..
217* .. Local Scalars ..
218 CHARACTER TRANST
219 INTEGER I, J
220* ..
221* .. External Functions ..
222 LOGICAL LSAME
223 EXTERNAL lsame
224* ..
225* .. External Subroutines ..
226 EXTERNAL zcopy, zgemm, zlacgv, ztrmm
227* ..
228* .. Intrinsic Functions ..
229 INTRINSIC dconjg
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 zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
263 CALL zlacgv( n, work( 1, j ), 1 )
264 10 CONTINUE
265*
266* W := W * V1
267*
268 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 ) - dconjg( 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 zcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
318 40 CONTINUE
319*
320* W := W * V1
321*
322 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
380 CALL zlacgv( n, work( 1, j ), 1 )
381 70 CONTINUE
382*
383* W := W * V2
384*
385 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 $ dconjg( 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 zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
437 100 CONTINUE
438*
439* W := W * V2
440*
441 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 )
501 CALL zlacgv( n, work( 1, j ), 1 )
502 130 CONTINUE
503*
504* W := W * V1**H
505*
506 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 ) - dconjg( 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 zcopy( m, c( 1, j ), 1, work( 1, j ), 1 )
558 160 CONTINUE
559*
560* W := W * V1**H
561*
562 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 )
620 CALL zlacgv( n, work( 1, j ), 1 )
621 190 CONTINUE
622*
623* W := W * V2**H
624*
625 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 $ dconjg( 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 zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 )
677 220 CONTINUE
678*
679* W := W * V2**H
680*
681 CALL ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 ZLARFB
729*

◆ zlarfb_gett()

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

ZLARFB_GETT

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

Purpose:
!>
!> ZLARFB_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*16 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*16 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*16 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*16 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 zlarfb_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*16 A( LDA, * ), B( LDB, * ), T( LDT, * ),
404 $ WORK( LDWORK, * )
405* ..
406*
407* =====================================================================
408*
409* .. Parameters ..
410 COMPLEX*16 CONE, CZERO
411 parameter( cone = ( 1.0d+0, 0.0d+0 ),
412 $ czero = ( 0.0d+0, 0.0d+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 zcopy, zgemm, ztrmm
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 zcopy( 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 ztrmm( '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 zgemm( '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 ztrmm( '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 zgemm( '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 ztrmm( '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 zcopy( 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 ztrmm( '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 ztrmm( '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 ztrmm( '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 ztrmm( '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 ZLARFB_GETT
596*

◆ zlarfg()

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

ZLARFG generates an elementary reflector (Householder matrix).

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

Purpose:
!>
!> ZLARFG 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*16
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is COMPLEX*16 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*16
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file zlarfg.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*16 ALPHA, TAU
114* ..
115* .. Array Arguments ..
116 COMPLEX*16 X( * )
117* ..
118*
119* =====================================================================
120*
121* .. Parameters ..
122 DOUBLE PRECISION ONE, ZERO
123 parameter( one = 1.0d+0, zero = 0.0d+0 )
124* ..
125* .. Local Scalars ..
126 INTEGER J, KNT
127 DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
128* ..
129* .. External Functions ..
130 DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2
131 COMPLEX*16 ZLADIV
132 EXTERNAL dlamch, dlapy3, dznrm2, zladiv
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC abs, dble, dcmplx, dimag, sign
136* ..
137* .. External Subroutines ..
138 EXTERNAL zdscal, zscal
139* ..
140* .. Executable Statements ..
141*
142 IF( n.LE.0 ) THEN
143 tau = zero
144 RETURN
145 END IF
146*
147 xnorm = dznrm2( n-1, x, incx )
148 alphr = dble( alpha )
149 alphi = dimag( 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( dlapy3( alphr, alphi, xnorm ), alphr )
161 safmin = dlamch( 'S' ) / dlamch( '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 zdscal( 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 = dznrm2( n-1, x, incx )
181 alpha = dcmplx( alphr, alphi )
182 beta = -sign( dlapy3( alphr, alphi, xnorm ), alphr )
183 END IF
184 tau = dcmplx( ( beta-alphr ) / beta, -alphi / beta )
185 alpha = zladiv( dcmplx( one ), alpha-beta )
186 CALL zscal( 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 ZLARFG
199*
dlapy3
double precision function dlapy3(x, y, z)
DLAPY3 returns sqrt(x2+y2+z2).
Definition dlapy3.f:68

◆ zlarfgp()

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

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

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

Purpose:
!>
!> ZLARFGP 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*16
!>          On entry, the value alpha.
!>          On exit, it is overwritten with the value beta.
!>
[in,out]X
!>          X is COMPLEX*16 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*16
!>          The value tau.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file zlarfgp.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*16 ALPHA, TAU
112* ..
113* .. Array Arguments ..
114 COMPLEX*16 X( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 DOUBLE PRECISION TWO, ONE, ZERO
121 parameter( two = 2.0d+0, one = 1.0d+0, zero = 0.0d+0 )
122* ..
123* .. Local Scalars ..
124 INTEGER J, KNT
125 DOUBLE PRECISION ALPHI, ALPHR, BETA, BIGNUM, SMLNUM, XNORM
126 COMPLEX*16 SAVEALPHA
127* ..
128* .. External Functions ..
129 DOUBLE PRECISION DLAMCH, DLAPY3, DLAPY2, DZNRM2
130 COMPLEX*16 ZLADIV
131 EXTERNAL dlamch, dlapy3, dlapy2, dznrm2, zladiv
132* ..
133* .. Intrinsic Functions ..
134 INTRINSIC abs, dble, dcmplx, dimag, sign
135* ..
136* .. External Subroutines ..
137 EXTERNAL zdscal, zscal
138* ..
139* .. Executable Statements ..
140*
141 IF( n.LE.0 ) THEN
142 tau = zero
143 RETURN
144 END IF
145*
146 xnorm = dznrm2( n-1, x, incx )
147 alphr = dble( alpha )
148 alphi = dimag( 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 = dlapy2( alphr, alphi )
172 tau = dcmplx( 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( dlapy3( alphr, alphi, xnorm ), alphr )
183 smlnum = dlamch( 'S' ) / dlamch( '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 zdscal( 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 = dznrm2( n-1, x, incx )
203 alpha = dcmplx( alphr, alphi )
204 beta = sign( dlapy3( 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/dble( alpha ))
213 alphr = alphr + xnorm * (xnorm/dble( alpha ))
214 tau = dcmplx( alphr/beta, -alphi/beta )
215 alpha = dcmplx( -alphr, alphi )
216 END IF
217 alpha = zladiv( dcmplx( 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 = dble( savealpha )
229 alphi = dimag( 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 = dble( -savealpha )
239 END IF
240 ELSE
241 xnorm = dlapy2( alphr, alphi )
242 tau = dcmplx( 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 zscal( 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 ZLARFGP
268*
dlapy2
double precision function dlapy2(x, y)
DLAPY2 returns sqrt(x2+y2).
Definition dlapy2.f:63

◆ zlarft()

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

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

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

Purpose:
!>
!> ZLARFT 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*16 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*16 array, dimension (K)
!>          TAU(i) must contain the scalar factor of the elementary
!>          reflector H(i).
!>
[out]T
!>          T is COMPLEX*16 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 zlarft.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*16 T( LDT, * ), TAU( * ), V( LDV, * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 COMPLEX*16 ONE, ZERO
180 parameter( one = ( 1.0d+0, 0.0d+0 ),
181 $ zero = ( 0.0d+0, 0.0d+0 ) )
182* ..
183* .. Local Scalars ..
184 INTEGER I, J, PREVLASTV, LASTV
185* ..
186* .. External Subroutines ..
187 EXTERNAL zgemv, ztrmv, zgemm
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 zgemv( 'Conjugate transpose', j-i, i-1,
228 $ -tau( i ), v( i+1, 1 ), ldv,
229 $ v( i+1, i ), 1, one, t( 1, i ), 1 )
230 ELSE
231* Skip any trailing zeros.
232 DO lastv = n, i+1, -1
233 IF( v( i, lastv ).NE.zero ) EXIT
234 END DO
235 DO j = 1, i-1
236 t( j, i ) = -tau( i ) * v( j , i )
237 END DO
238 j = min( lastv, prevlastv )
239*
240* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H
241*
242 CALL zgemm( 'N', 'C', i-1, 1, j-i, -tau( i ),
243 $ v( 1, i+1 ), ldv, v( i, i+1 ), ldv,
244 $ one, t( 1, i ), ldt )
245 END IF
246*
247* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
248*
249 CALL ztrmv( 'Upper', 'No transpose', 'Non-unit', i-1, t,
250 $ ldt, t( 1, i ), 1 )
251 t( i, i ) = tau( i )
252 IF( i.GT.1 ) THEN
253 prevlastv = max( prevlastv, lastv )
254 ELSE
255 prevlastv = lastv
256 END IF
257 END IF
258 END DO
259 ELSE
260 prevlastv = 1
261 DO i = k, 1, -1
262 IF( tau( i ).EQ.zero ) THEN
263*
264* H(i) = I
265*
266 DO j = i, k
267 t( j, i ) = zero
268 END DO
269 ELSE
270*
271* general case
272*
273 IF( i.LT.k ) THEN
274 IF( lsame( storev, 'C' ) ) THEN
275* Skip any leading zeros.
276 DO lastv = 1, i-1
277 IF( v( lastv, i ).NE.zero ) EXIT
278 END DO
279 DO j = i+1, k
280 t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) )
281 END DO
282 j = max( lastv, prevlastv )
283*
284* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i)
285*
286 CALL zgemv( 'Conjugate transpose', n-k+i-j, k-i,
287 $ -tau( i ), v( j, i+1 ), ldv, v( j, i ),
288 $ 1, one, t( i+1, i ), 1 )
289 ELSE
290* Skip any leading zeros.
291 DO lastv = 1, i-1
292 IF( v( i, lastv ).NE.zero ) EXIT
293 END DO
294 DO j = i+1, k
295 t( j, i ) = -tau( i ) * v( j, n-k+i )
296 END DO
297 j = max( lastv, prevlastv )
298*
299* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H
300*
301 CALL zgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),
302 $ v( i+1, j ), ldv, v( i, j ), ldv,
303 $ one, t( i+1, i ), ldt )
304 END IF
305*
306* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
307*
308 CALL ztrmv( 'Lower', 'No transpose', 'Non-unit', k-i,
309 $ t( i+1, i+1 ), ldt, t( i+1, i ), 1 )
310 IF( i.GT.1 ) THEN
311 prevlastv = min( prevlastv, lastv )
312 ELSE
313 prevlastv = lastv
314 END IF
315 END IF
316 t( i, i ) = tau( i )
317 END IF
318 END DO
319 END IF
320 RETURN
321*
322* End of ZLARFT
323*

◆ zlarfx()

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

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

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

Purpose:
!>
!> ZLARFX 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*16 array, dimension (M) if SIDE = 'L'
!>                                        or (N) if SIDE = 'R'
!>          The vector v in the representation of H.
!>
[in]TAU
!>          TAU is COMPLEX*16
!>          The value tau in the representation of H.
!>
[in,out]C
!>          C is COMPLEX*16 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*16 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 zlarfx.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*16 TAU
128* ..
129* .. Array Arguments ..
130 COMPLEX*16 C( LDC, * ), V( * ), WORK( * )
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 COMPLEX*16 ZERO, ONE
137 parameter( zero = ( 0.0d+0, 0.0d+0 ),
138 $ one = ( 1.0d+0, 0.0d+0 ) )
139* ..
140* .. Local Scalars ..
141 INTEGER J
142 COMPLEX*16 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 zlarf
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC dconjg
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 zlarf( 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 )*dconjg( 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 = dconjg( v( 1 ) )
184 t1 = tau*dconjg( v1 )
185 v2 = dconjg( v( 2 ) )
186 t2 = tau*dconjg( 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 = dconjg( v( 1 ) )
198 t1 = tau*dconjg( v1 )
199 v2 = dconjg( v( 2 ) )
200 t2 = tau*dconjg( v2 )
201 v3 = dconjg( v( 3 ) )
202 t3 = tau*dconjg( 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 = dconjg( v( 1 ) )
215 t1 = tau*dconjg( v1 )
216 v2 = dconjg( v( 2 ) )
217 t2 = tau*dconjg( v2 )
218 v3 = dconjg( v( 3 ) )
219 t3 = tau*dconjg( v3 )
220 v4 = dconjg( v( 4 ) )
221 t4 = tau*dconjg( 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 = dconjg( v( 1 ) )
236 t1 = tau*dconjg( v1 )
237 v2 = dconjg( v( 2 ) )
238 t2 = tau*dconjg( v2 )
239 v3 = dconjg( v( 3 ) )
240 t3 = tau*dconjg( v3 )
241 v4 = dconjg( v( 4 ) )
242 t4 = tau*dconjg( v4 )
243 v5 = dconjg( v( 5 ) )
244 t5 = tau*dconjg( 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 = dconjg( v( 1 ) )
260 t1 = tau*dconjg( v1 )
261 v2 = dconjg( v( 2 ) )
262 t2 = tau*dconjg( v2 )
263 v3 = dconjg( v( 3 ) )
264 t3 = tau*dconjg( v3 )
265 v4 = dconjg( v( 4 ) )
266 t4 = tau*dconjg( v4 )
267 v5 = dconjg( v( 5 ) )
268 t5 = tau*dconjg( v5 )
269 v6 = dconjg( v( 6 ) )
270 t6 = tau*dconjg( 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 = dconjg( v( 1 ) )
287 t1 = tau*dconjg( v1 )
288 v2 = dconjg( v( 2 ) )
289 t2 = tau*dconjg( v2 )
290 v3 = dconjg( v( 3 ) )
291 t3 = tau*dconjg( v3 )
292 v4 = dconjg( v( 4 ) )
293 t4 = tau*dconjg( v4 )
294 v5 = dconjg( v( 5 ) )
295 t5 = tau*dconjg( v5 )
296 v6 = dconjg( v( 6 ) )
297 t6 = tau*dconjg( v6 )
298 v7 = dconjg( v( 7 ) )
299 t7 = tau*dconjg( 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 = dconjg( v( 1 ) )
318 t1 = tau*dconjg( v1 )
319 v2 = dconjg( v( 2 ) )
320 t2 = tau*dconjg( v2 )
321 v3 = dconjg( v( 3 ) )
322 t3 = tau*dconjg( v3 )
323 v4 = dconjg( v( 4 ) )
324 t4 = tau*dconjg( v4 )
325 v5 = dconjg( v( 5 ) )
326 t5 = tau*dconjg( v5 )
327 v6 = dconjg( v( 6 ) )
328 t6 = tau*dconjg( v6 )
329 v7 = dconjg( v( 7 ) )
330 t7 = tau*dconjg( v7 )
331 v8 = dconjg( v( 8 ) )
332 t8 = tau*dconjg( 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 = dconjg( v( 1 ) )
352 t1 = tau*dconjg( v1 )
353 v2 = dconjg( v( 2 ) )
354 t2 = tau*dconjg( v2 )
355 v3 = dconjg( v( 3 ) )
356 t3 = tau*dconjg( v3 )
357 v4 = dconjg( v( 4 ) )
358 t4 = tau*dconjg( v4 )
359 v5 = dconjg( v( 5 ) )
360 t5 = tau*dconjg( v5 )
361 v6 = dconjg( v( 6 ) )
362 t6 = tau*dconjg( v6 )
363 v7 = dconjg( v( 7 ) )
364 t7 = tau*dconjg( v7 )
365 v8 = dconjg( v( 8 ) )
366 t8 = tau*dconjg( v8 )
367 v9 = dconjg( v( 9 ) )
368 t9 = tau*dconjg( 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 = dconjg( v( 1 ) )
389 t1 = tau*dconjg( v1 )
390 v2 = dconjg( v( 2 ) )
391 t2 = tau*dconjg( v2 )
392 v3 = dconjg( v( 3 ) )
393 t3 = tau*dconjg( v3 )
394 v4 = dconjg( v( 4 ) )
395 t4 = tau*dconjg( v4 )
396 v5 = dconjg( v( 5 ) )
397 t5 = tau*dconjg( v5 )
398 v6 = dconjg( v( 6 ) )
399 t6 = tau*dconjg( v6 )
400 v7 = dconjg( v( 7 ) )
401 t7 = tau*dconjg( v7 )
402 v8 = dconjg( v( 8 ) )
403 t8 = tau*dconjg( v8 )
404 v9 = dconjg( v( 9 ) )
405 t9 = tau*dconjg( v9 )
406 v10 = dconjg( v( 10 ) )
407 t10 = tau*dconjg( 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 zlarf( 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 )*dconjg( 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*dconjg( v1 )
451 v2 = v( 2 )
452 t2 = tau*dconjg( 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*dconjg( v1 )
465 v2 = v( 2 )
466 t2 = tau*dconjg( v2 )
467 v3 = v( 3 )
468 t3 = tau*dconjg( 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*dconjg( v1 )
482 v2 = v( 2 )
483 t2 = tau*dconjg( v2 )
484 v3 = v( 3 )
485 t3 = tau*dconjg( v3 )
486 v4 = v( 4 )
487 t4 = tau*dconjg( 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*dconjg( v1 )
503 v2 = v( 2 )
504 t2 = tau*dconjg( v2 )
505 v3 = v( 3 )
506 t3 = tau*dconjg( v3 )
507 v4 = v( 4 )
508 t4 = tau*dconjg( v4 )
509 v5 = v( 5 )
510 t5 = tau*dconjg( 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*dconjg( v1 )
527 v2 = v( 2 )
528 t2 = tau*dconjg( v2 )
529 v3 = v( 3 )
530 t3 = tau*dconjg( v3 )
531 v4 = v( 4 )
532 t4 = tau*dconjg( v4 )
533 v5 = v( 5 )
534 t5 = tau*dconjg( v5 )
535 v6 = v( 6 )
536 t6 = tau*dconjg( 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*dconjg( v1 )
554 v2 = v( 2 )
555 t2 = tau*dconjg( v2 )
556 v3 = v( 3 )
557 t3 = tau*dconjg( v3 )
558 v4 = v( 4 )
559 t4 = tau*dconjg( v4 )
560 v5 = v( 5 )
561 t5 = tau*dconjg( v5 )
562 v6 = v( 6 )
563 t6 = tau*dconjg( v6 )
564 v7 = v( 7 )
565 t7 = tau*dconjg( 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*dconjg( v1 )
585 v2 = v( 2 )
586 t2 = tau*dconjg( v2 )
587 v3 = v( 3 )
588 t3 = tau*dconjg( v3 )
589 v4 = v( 4 )
590 t4 = tau*dconjg( v4 )
591 v5 = v( 5 )
592 t5 = tau*dconjg( v5 )
593 v6 = v( 6 )
594 t6 = tau*dconjg( v6 )
595 v7 = v( 7 )
596 t7 = tau*dconjg( v7 )
597 v8 = v( 8 )
598 t8 = tau*dconjg( 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*dconjg( v1 )
619 v2 = v( 2 )
620 t2 = tau*dconjg( v2 )
621 v3 = v( 3 )
622 t3 = tau*dconjg( v3 )
623 v4 = v( 4 )
624 t4 = tau*dconjg( v4 )
625 v5 = v( 5 )
626 t5 = tau*dconjg( v5 )
627 v6 = v( 6 )
628 t6 = tau*dconjg( v6 )
629 v7 = v( 7 )
630 t7 = tau*dconjg( v7 )
631 v8 = v( 8 )
632 t8 = tau*dconjg( v8 )
633 v9 = v( 9 )
634 t9 = tau*dconjg( 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*dconjg( v1 )
656 v2 = v( 2 )
657 t2 = tau*dconjg( v2 )
658 v3 = v( 3 )
659 t3 = tau*dconjg( v3 )
660 v4 = v( 4 )
661 t4 = tau*dconjg( v4 )
662 v5 = v( 5 )
663 t5 = tau*dconjg( v5 )
664 v6 = v( 6 )
665 t6 = tau*dconjg( v6 )
666 v7 = v( 7 )
667 t7 = tau*dconjg( v7 )
668 v8 = v( 8 )
669 t8 = tau*dconjg( v8 )
670 v9 = v( 9 )
671 t9 = tau*dconjg( v9 )
672 v10 = v( 10 )
673 t10 = tau*dconjg( 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 CONTINUE
693 RETURN
694*
695* End of ZLARFX
696*

◆ zlarfy()

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

ZLARFY

Purpose:
!>
!> ZLARFY 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*16 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*16
!>          The value tau as described above.
!>
[in,out]C
!>          C is COMPLEX*16 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*16 array, dimension (N)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ zlargv()

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

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

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

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

◆ zlarnv()

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

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

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

Purpose:
!>
!> ZLARNV 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*16 array, dimension (N)
!>          The generated random numbers.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  This routine calls the auxiliary routine DLARUV to generate random
!>  real numbers from a uniform (0,1) distribution, in batches of up to
!>  128 using vectorisable code. The Box-Muller method is used to
!>  transform numbers from a uniform to a normal distribution.
!>

Definition at line 98 of file zlarnv.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*16 X( * )
110* ..
111*
112* =====================================================================
113*
114* .. Parameters ..
115 DOUBLE PRECISION ZERO, ONE, TWO
116 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
117 INTEGER LV
118 parameter( lv = 128 )
119 DOUBLE PRECISION TWOPI
120 parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
121* ..
122* .. Local Scalars ..
123 INTEGER I, IL, IV
124* ..
125* .. Local Arrays ..
126 DOUBLE PRECISION U( LV )
127* ..
128* .. Intrinsic Functions ..
129 INTRINSIC dcmplx, exp, log, min, sqrt
130* ..
131* .. External Subroutines ..
132 EXTERNAL dlaruv
133* ..
134* .. Executable Statements ..
135*
136 DO 60 iv = 1, n, lv / 2
137 il = min( lv / 2, n-iv+1 )
138*
139* Call DLARUV to generate 2*IL real numbers from a uniform (0,1)
140* distribution (2*IL <= LV)
141*
142 CALL dlaruv( 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 ) = dcmplx( 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 ) = dcmplx( 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( dcmplx( 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( dcmplx( 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( dcmplx( zero, twopi*u( 2*i ) ) )
183 50 CONTINUE
184 END IF
185 60 CONTINUE
186 RETURN
187*
188* End of ZLARNV
189*
dlaruv
subroutine dlaruv(iseed, n, x)
DLARUV returns a vector of n random real numbers from a uniform distribution.
Definition dlaruv.f:95

◆ zlarrv()

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

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

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

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

Definition at line 281 of file zlarrv.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 DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
294* ..
295* .. Array Arguments ..
296 INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
297 $ ISUPPZ( * ), IWORK( * )
298 DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
299 $ WGAP( * ), WORK( * )
300 COMPLEX*16 Z( LDZ, * )
301* ..
302*
303* =====================================================================
304*
305* .. Parameters ..
306 INTEGER MAXITR
307 parameter( maxitr = 10 )
308 COMPLEX*16 CZERO
309 parameter( czero = ( 0.0d0, 0.0d0 ) )
310 DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
311 parameter( zero = 0.0d0, one = 1.0d0,
312 $ two = 2.0d0, three = 3.0d0,
313 $ four = 4.0d0, half = 0.5d0)
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 DOUBLE PRECISION 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 DOUBLE PRECISION DLAMCH
334 EXTERNAL dlamch
335* ..
336* .. External Subroutines ..
337 EXTERNAL dcopy, dlarrb, dlarrf, zdscal, zlar1v,
338 $ zlaset
339* ..
340* .. Intrinsic Functions ..
341 INTRINSIC abs, dble, max, min
342 INTRINSIC dcmplx
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 zlaset( 'Full', n, zusedw, czero, czero,
396 $ z(1,zusedl), ldz )
397
398 eps = dlamch( 'Precision' )
399 rqtol = two * eps
400*
401* Set expert flags for standard code.
402 tryrqc = .true.
403
404 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
405 ELSE
406* Only selected eigenpairs are computed. Since the other evalues
407* are not refined by RQ iteration, bisection has to compute to full
408* accuracy.
409 rtol1 = four * eps
410 rtol2 = four * eps
411 ENDIF
412
413* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
414* desired eigenvalues. The support of the nonzero eigenvector
415* entries is contained in the interval IBEGIN:IEND.
416* Remark that if k eigenpairs are desired, then the eigenvectors
417* are stored in k contiguous columns of Z.
418
419* DONE is the number of eigenvectors already computed
420 done = 0
421 ibegin = 1
422 wbegin = 1
423 DO 170 jblk = 1, iblock( m )
424 iend = isplit( jblk )
425 sigma = l( iend )
426* Find the eigenvectors of the submatrix indexed IBEGIN
427* through IEND.
428 wend = wbegin - 1
429 15 CONTINUE
430 IF( wend.LT.m ) THEN
431 IF( iblock( wend+1 ).EQ.jblk ) THEN
432 wend = wend + 1
433 GO TO 15
434 END IF
435 END IF
436 IF( wend.LT.wbegin ) THEN
437 ibegin = iend + 1
438 GO TO 170
439 ELSEIF( (wend.LT.dol).OR.(wbegin.GT.dou) ) THEN
440 ibegin = iend + 1
441 wbegin = wend + 1
442 GO TO 170
443 END IF
444
445* Find local spectral diameter of the block
446 gl = gers( 2*ibegin-1 )
447 gu = gers( 2*ibegin )
448 DO 20 i = ibegin+1 , iend
449 gl = min( gers( 2*i-1 ), gl )
450 gu = max( gers( 2*i ), gu )
451 20 CONTINUE
452 spdiam = gu - gl
453
454* OLDIEN is the last index of the previous block
455 oldien = ibegin - 1
456* Calculate the size of the current block
457 in = iend - ibegin + 1
458* The number of eigenvalues in the current block
459 im = wend - wbegin + 1
460
461* This is for a 1x1 block
462 IF( ibegin.EQ.iend ) THEN
463 done = done+1
464 z( ibegin, wbegin ) = dcmplx( 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 dcopy( im, w( wbegin ), 1,
481 $ work( wbegin ), 1 )
482
483* We store in W the eigenvalue approximations w.r.t. the original
484* matrix T.
485 DO 30 i=1,im
486 w(wbegin+i-1) = w(wbegin+i-1)+sigma
487 30 CONTINUE
488
489
490* NDEPTH is the current depth of the representation tree
491 ndepth = 0
492* PARITY is either 1 or 0
493 parity = 1
494* NCLUS is the number of clusters for the next level of the
495* representation tree, we start with NCLUS = 1 for the root
496 nclus = 1
497 iwork( iindc1+1 ) = 1
498 iwork( iindc1+2 ) = im
499
500* IDONE is the number of eigenvectors already computed in the current
501* block
502 idone = 0
503* loop while( IDONE.LT.IM )
504* generate the representation tree for the current block and
505* compute the eigenvectors
506 40 CONTINUE
507 IF( idone.LT.im ) THEN
508* This is a crude protection against infinitely deep trees
509 IF( ndepth.GT.m ) THEN
510 info = -2
511 RETURN
512 ENDIF
513* breadth first processing of the current level of the representation
514* tree: OLDNCL = number of clusters on current level
515 oldncl = nclus
516* reset NCLUS to count the number of child clusters
517 nclus = 0
518*
519 parity = 1 - parity
520 IF( parity.EQ.0 ) THEN
521 oldcls = iindc1
522 newcls = iindc2
523 ELSE
524 oldcls = iindc2
525 newcls = iindc1
526 END IF
527* Process the clusters on the current level
528 DO 150 i = 1, oldncl
529 j = oldcls + 2*i
530* OLDFST, OLDLST = first, last index of current cluster.
531* cluster indices start with 1 and are relative
532* to WBEGIN when accessing W, WGAP, WERR, Z
533 oldfst = iwork( j-1 )
534 oldlst = iwork( j )
535 IF( ndepth.GT.0 ) THEN
536* Retrieve relatively robust representation (RRR) of cluster
537* that has been computed at the previous level
538* The RRR is stored in Z and overwritten once the eigenvectors
539* have been computed or when the cluster is refined
540
541 IF((dol.EQ.1).AND.(dou.EQ.m)) THEN
542* Get representation from location of the leftmost evalue
543* of the cluster
544 j = wbegin + oldfst - 1
545 ELSE
546 IF(wbegin+oldfst-1.LT.dol) THEN
547* Get representation from the left end of Z array
548 j = dol - 1
549 ELSEIF(wbegin+oldfst-1.GT.dou) THEN
550* Get representation from the right end of Z array
551 j = dou
552 ELSE
553 j = wbegin + oldfst - 1
554 ENDIF
555 ENDIF
556 DO 45 k = 1, in - 1
557 d( ibegin+k-1 ) = dble( z( ibegin+k-1,
558 $ j ) )
559 l( ibegin+k-1 ) = dble( z( ibegin+k-1,
560 $ j+1 ) )
561 45 CONTINUE
562 d( iend ) = dble( z( iend, j ) )
563 sigma = dble( z( iend, j+1 ) )
564
565* Set the corresponding entries in Z to zero
566 CALL zlaset( '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 dlarrb( 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 DLARRB.
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 dlarrb( 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* DLARRF needs LWORK = 2*N
724 CALL dlarrf( 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, DLARRF 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 $ dcmplx( work( indin1+k-1 ), zero )
737 z( ibegin+k-1, newftt+1 ) =
738 $ dcmplx( work( indin2+k-1 ), zero )
739 56 CONTINUE
740 z( iend, newftt ) =
741 $ dcmplx( work( indin1+in-1 ), zero )
742 IF( iinfo.EQ.0 ) THEN
743* a new RRR for the cluster was found by DLARRF
744* update shift and store it
745 ssigma = sigma + tau
746 z( iend, newftt+1 ) = dcmplx( 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(dble(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 dlarrb( 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 zlar1v( 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 zlar1v( 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 zdscal( 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 ZLARRV
1056*
dlarrb
subroutine dlarrb(n, d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, work, iwork, pivmin, spdiam, twist, info)
DLARRB provides limited bisection to locate eigenvalues for more accuracy.
Definition dlarrb.f:196
dlarrf
subroutine dlarrf(n, d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, sigma, dplus, lplus, work, info)
DLARRF finds a new relatively robust representation such that at least one of the eigenvalues is rela...
Definition dlarrf.f:193
zlar1v
subroutine zlar1v(n, b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, negcnt, ztz, mingma, r, isuppz, nrminv, resid, rqcorr, work)
ZLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn of the...
Definition zlar1v.f:230
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ zlartv()

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

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

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

Purpose:
!>
!> ZLARTV 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*16 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*16 array, dimension (1+(N-1)*INCY)
!>          The vector y.
!>
[in]INCY
!>          INCY is INTEGER
!>          The increment between elements of Y. INCY > 0.
!>
[in]C
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!>
[in]S
!>          S is COMPLEX*16 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 zlartv.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 DOUBLE PRECISION C( * )
117 COMPLEX*16 S( * ), X( * ), Y( * )
118* ..
119*
120* =====================================================================
121*
122* .. Local Scalars ..
123 INTEGER I, IC, IX, IY
124 COMPLEX*16 XI, YI
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC dconjg
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 - dconjg( s( ic ) )*xi
139 ix = ix + incx
140 iy = iy + incy
141 ic = ic + incc
142 10 CONTINUE
143 RETURN
144*
145* End of ZLARTV
146*

◆ zlascl()

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

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

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

Purpose:
!>
!> ZLASCL 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 ZGBTRF for storage details.
!>
[in]KL
!>          KL is INTEGER
!>          The lower bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]KU
!>          KU is INTEGER
!>          The upper bandwidth of A.  Referenced only if TYPE = 'B',
!>          'Q' or 'Z'.
!>
[in]CFROM
!>          CFROM is DOUBLE PRECISION
!>
[in]CTO
!>          CTO is DOUBLE PRECISION
!>
!>          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
!>          without over/underflow if the final result CTO*A(I,J)/CFROM
!>          can be represented without over/underflow.  CFROM must be
!>          nonzero.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 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 zlascl.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 DOUBLE PRECISION CFROM, CTO
152* ..
153* .. Array Arguments ..
154 COMPLEX*16 A( LDA, * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 DOUBLE PRECISION ZERO, ONE
161 parameter( zero = 0.0d0, one = 1.0d0 )
162* ..
163* .. Local Scalars ..
164 LOGICAL DONE
165 INTEGER I, ITYPE, J, K1, K2, K3, K4
166 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
167* ..
168* .. External Functions ..
169 LOGICAL LSAME, DISNAN
170 DOUBLE PRECISION DLAMCH
171 EXTERNAL lsame, dlamch, disnan
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. disnan(cfrom) ) THEN
206 info = -4
207 ELSE IF( disnan(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( 'ZLASCL', -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 = dlamch( '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 ZLASCL
364*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ zlaset()

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

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

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

Purpose:
!>
!> ZLASET 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*16
!>          All the offdiagonal array elements are set to ALPHA.
!>
[in]BETA
!>          BETA is COMPLEX*16
!>          All the diagonal array elements are set to BETA.
!>
[out]A
!>          A is COMPLEX*16 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 zlaset.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*16 ALPHA, BETA
115* ..
116* .. Array Arguments ..
117 COMPLEX*16 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 ZLASET
180*

◆ zlasr()

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

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

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

Purpose:
!>
!> ZLASR 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 DOUBLE PRECISION array, dimension
!>                  (M-1) if SIDE = 'L'
!>                  (N-1) if SIDE = 'R'
!>          The cosines c(k) of the plane rotations.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension
!>                  (M-1) if SIDE = 'L'
!>                  (N-1) if SIDE = 'R'
!>          The sines s(k) of the plane rotations.  The 2-by-2 plane
!>          rotation part of the matrix P(k), R(k), has the form
!>          R(k) = (  c(k)  s(k) )
!>                 ( -s(k)  c(k) ).
!>
[in,out]A
!>          A is COMPLEX*16 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 zlasr.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 DOUBLE PRECISION C( * ), S( * )
211 COMPLEX*16 A( LDA, * )
212* ..
213*
214* =====================================================================
215*
216* .. Parameters ..
217 DOUBLE PRECISION ONE, ZERO
218 parameter( one = 1.0d+0, zero = 0.0d+0 )
219* ..
220* .. Local Scalars ..
221 INTEGER I, INFO, J
222 DOUBLE PRECISION CTEMP, STEMP
223 COMPLEX*16 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( 'ZLASR ', 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 ZLASR
435*

◆ zlaswp()

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

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

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

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

◆ zlat2c()

subroutine zlat2c ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex, dimension( ldsa, * ) sa,
integer ldsa,
integer info )

ZLAT2C converts a double complex triangular matrix to a complex triangular matrix.

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

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

Definition at line 110 of file zlat2c.f.

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

◆ zlatbs()

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

ZLATBS solves a triangular banded system of equations.

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

Purpose:
!>
!> ZLATBS 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 ZTBSV 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*16 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*16 array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  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 DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, ZTBSV
!>  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 ZTBSV 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 ZTBSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 241 of file zlatbs.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 DOUBLE PRECISION SCALE
252* ..
253* .. Array Arguments ..
254 DOUBLE PRECISION CNORM( * )
255 COMPLEX*16 AB( LDAB, * ), X( * )
256* ..
257*
258* =====================================================================
259*
260* .. Parameters ..
261 DOUBLE PRECISION ZERO, HALF, ONE, TWO
262 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
263 $ two = 2.0d+0 )
264* ..
265* .. Local Scalars ..
266 LOGICAL NOTRAN, NOUNIT, UPPER
267 INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
268 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
269 $ XBND, XJ, XMAX
270 COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
271* ..
272* .. External Functions ..
273 LOGICAL LSAME
274 INTEGER IDAMAX, IZAMAX
275 DOUBLE PRECISION DLAMCH, DZASUM
276 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
277 EXTERNAL lsame, idamax, izamax, dlamch, dzasum, zdotc,
278 $ zdotu, zladiv
279* ..
280* .. External Subroutines ..
281 EXTERNAL dscal, xerbla, zaxpy, zdscal, ztbsv, dlabad
282* ..
283* .. Intrinsic Functions ..
284 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
285* ..
286* .. Statement Functions ..
287 DOUBLE PRECISION CABS1, CABS2
288* ..
289* .. Statement Function definitions ..
290 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
291 cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) +
292 $ abs( dimag( zdum ) / 2.d0 )
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( 'ZLATBS', -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 = dlamch( 'Safe minimum' )
333 bignum = one / smlnum
334 CALL dlabad( smlnum, bignum )
335 smlnum = smlnum / dlamch( '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 ) = dzasum( 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 ) = dzasum( 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 = idamax( 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 dscal( 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 ZTBSV 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 ztbsv( 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 zdscal( 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 120 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 110
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 zdscal( n, rec, x, 1 )
604 scale = scale*rec
605 xmax = xmax*rec
606 END IF
607 END IF
608 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
628 scale = scale*rec
629 xmax = xmax*rec
630 END IF
631 x( j ) = zladiv( 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 110 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 zdscal( 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 zdscal( 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 zaxpy( jlen, -x( j )*tscal,
678 $ ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 )
679 i = izamax( 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 zaxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,
691 $ x( j+1 ), 1 )
692 i = j + izamax( n-j, x( j+1 ), 1 )
693 xmax = cabs1( x( i ) )
694 END IF
695 120 CONTINUE
696*
697 ELSE IF( lsame( trans, 'T' ) ) THEN
698*
699* Solve A**T * x = b
700*
701 DO 170 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 = zladiv( uscal, tjjs )
726 END IF
727 IF( rec.LT.one ) THEN
728 CALL zdscal( 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.dcmplx( one ) ) THEN
736*
737* If the scaling needed for A in the dot product is 1,
738* call ZDOTU to perform the dot product.
739*
740 IF( upper ) THEN
741 jlen = min( kd, j-1 )
742 csumj = zdotu( 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 = zdotu( 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 130 i = 1, jlen
757 csumj = csumj + ( ab( kd+i-jlen, j )*uscal )*
758 $ x( j-jlen-1+i )
759 130 CONTINUE
760 ELSE
761 jlen = min( kd, n-j )
762 DO 140 i = 1, jlen
763 csumj = csumj + ( ab( i+1, j )*uscal )*x( j+i )
764 140 CONTINUE
765 END IF
766 END IF
767*
768 IF( uscal.EQ.dcmplx( 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 160
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 zdscal( n, rec, x, 1 )
797 scale = scale*rec
798 xmax = xmax*rec
799 END IF
800 END IF
801 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
812 scale = scale*rec
813 xmax = xmax*rec
814 END IF
815 x( j ) = zladiv( 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 150 i = 1, n
822 x( i ) = zero
823 150 CONTINUE
824 x( j ) = one
825 scale = zero
826 xmax = zero
827 END IF
828 160 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 ) = zladiv( x( j ), tjjs ) - csumj
835 END IF
836 xmax = max( xmax, cabs1( x( j ) ) )
837 170 CONTINUE
838*
839 ELSE
840*
841* Solve A**H * x = b
842*
843 DO 220 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 = dconjg( 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 = zladiv( uscal, tjjs )
868 END IF
869 IF( rec.LT.one ) THEN
870 CALL zdscal( 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.dcmplx( one ) ) THEN
878*
879* If the scaling needed for A in the dot product is 1,
880* call ZDOTC to perform the dot product.
881*
882 IF( upper ) THEN
883 jlen = min( kd, j-1 )
884 csumj = zdotc( 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 = zdotc( 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 180 i = 1, jlen
899 csumj = csumj + ( dconjg( ab( kd+i-jlen, j ) )*
900 $ uscal )*x( j-jlen-1+i )
901 180 CONTINUE
902 ELSE
903 jlen = min( kd, n-j )
904 DO 190 i = 1, jlen
905 csumj = csumj + ( dconjg( ab( i+1, j ) )*uscal )
906 $ *x( j+i )
907 190 CONTINUE
908 END IF
909 END IF
910*
911 IF( uscal.EQ.dcmplx( 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 = dconjg( ab( maind, j ) )*tscal
923 ELSE
924 tjjs = tscal
925 IF( tscal.EQ.one )
926 $ GO TO 210
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 zdscal( n, rec, x, 1 )
940 scale = scale*rec
941 xmax = xmax*rec
942 END IF
943 END IF
944 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
955 scale = scale*rec
956 xmax = xmax*rec
957 END IF
958 x( j ) = zladiv( 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 200 i = 1, n
965 x( i ) = zero
966 200 CONTINUE
967 x( j ) = one
968 scale = zero
969 xmax = zero
970 END IF
971 210 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 ) = zladiv( x( j ), tjjs ) - csumj
978 END IF
979 xmax = max( xmax, cabs1( x( j ) ) )
980 220 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 dscal( n, one / tscal, cnorm, 1 )
989 END IF
990*
991 RETURN
992*
993* End of ZLATBS
994*
zdotu
complex *16 function zdotu(n, zx, incx, zy, incy)
ZDOTU
Definition zdotu.f:83
ztbsv
subroutine ztbsv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBSV
Definition ztbsv.f:189
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79

◆ zlatdf()

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

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

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

Purpose:
!>
!> ZLATDF 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 ZGETC2. On entry RHS = f holds the
!> contribution from earlier solved sub-systems, and on return RHS = x.
!>
!> The factorization of Z returned by ZGETC2 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 ZGECON, 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*16 array, dimension (LDZ, N)
!>          On entry, the LU part of the factorization of the n-by-n
!>          matrix Z computed by ZGETC2:  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*16 array, dimension (N).
!>          On entry, RHS contains contributions from other subsystems.
!>          On exit, RHS contains the solution of the subsystem with
!>          entries according to the value of IJOB (see above).
!>
[in,out]RDSUM
!>          RDSUM is DOUBLE PRECISION
!>          On entry, the sum of squares of computed contributions to
!>          the Dif-estimate under computation by ZTGSYL, 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 ZTGSY2 is called by CTGSYL.
!>
[in,out]RDSCAL
!>          RDSCAL is DOUBLE PRECISION
!>          On entry, scaling factor used to prevent overflow in RDSUM.
!>          On exit, RDSCAL is updated w.r.t. the current contributions
!>          in RDSUM.
!>          If TRANS = 'T', RDSCAL is not touched.
!>          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
!>          ZTGSYL.
!>
[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 zlatdf.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 DOUBLE PRECISION RDSCAL, RDSUM
177* ..
178* .. Array Arguments ..
179 INTEGER IPIV( * ), JPIV( * )
180 COMPLEX*16 RHS( * ), Z( LDZ, * )
181* ..
182*
183* =====================================================================
184*
185* .. Parameters ..
186 INTEGER MAXDIM
187 parameter( maxdim = 2 )
188 DOUBLE PRECISION ZERO, ONE
189 parameter( zero = 0.0d+0, one = 1.0d+0 )
190 COMPLEX*16 CONE
191 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
192* ..
193* .. Local Scalars ..
194 INTEGER I, INFO, J, K
195 DOUBLE PRECISION RTEMP, SCALE, SMINU, SPLUS
196 COMPLEX*16 BM, BP, PMONE, TEMP
197* ..
198* .. Local Arrays ..
199 DOUBLE PRECISION RWORK( MAXDIM )
200 COMPLEX*16 WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
201* ..
202* .. External Subroutines ..
203 EXTERNAL zaxpy, zcopy, zgecon, zgesc2, zlassq, zlaswp,
204 $ zscal
205* ..
206* .. External Functions ..
207 DOUBLE PRECISION DZASUM
208 COMPLEX*16 ZDOTC
209 EXTERNAL dzasum, zdotc
210* ..
211* .. Intrinsic Functions ..
212 INTRINSIC abs, dble, sqrt
213* ..
214* .. Executable Statements ..
215*
216 IF( ijob.NE.2 ) THEN
217*
218* Apply permutations IPIV to RHS
219*
220 CALL zlaswp( 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 + dble( zdotc( n-j, z( j+1, j ), 1, z( j+1,
234 $ j ), 1 ) )
235 sminu = dble( zdotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ) )
236 splus = splus*dble( 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 zaxpy( 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 zcopy( 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 zcopy( n, work, 1, rhs, 1 )
282*
283* Apply the permutations JPIV to the computed solution (RHS)
284*
285 CALL zlaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 )
286*
287* Compute the sum of squares
288*
289 CALL zlassq( 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 zgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info )
298 CALL zcopy( n, work( n+1 ), 1, xm, 1 )
299*
300* Compute RHS
301*
302 CALL zlaswp( 1, xm, ldz, 1, n-1, ipiv, -1 )
303 temp = cone / sqrt( zdotc( n, xm, 1, xm, 1 ) )
304 CALL zscal( n, temp, xm, 1 )
305 CALL zcopy( n, xm, 1, xp, 1 )
306 CALL zaxpy( n, cone, rhs, 1, xp, 1 )
307 CALL zaxpy( n, -cone, xm, 1, rhs, 1 )
308 CALL zgesc2( n, z, ldz, rhs, ipiv, jpiv, scale )
309 CALL zgesc2( n, z, ldz, xp, ipiv, jpiv, scale )
310 IF( dzasum( n, xp, 1 ).GT.dzasum( n, rhs, 1 ) )
311 $ CALL zcopy( n, xp, 1, rhs, 1 )
312*
313* Compute the sum of squares
314*
315 CALL zlassq( n, rhs, 1, rdscal, rdsum )
316 RETURN
317*
318* End of ZLATDF
319*
zgesc2
subroutine zgesc2(n, a, lda, rhs, ipiv, jpiv, scale)
ZGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed...
Definition zgesc2.f:115
zgecon
subroutine zgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
ZGECON
Definition zgecon.f:124
zlaswp
subroutine zlaswp(n, a, lda, k1, k2, ipiv, incx)
ZLASWP performs a series of row interchanges on a general rectangular matrix.
Definition zlaswp.f:115

◆ zlatps()

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

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

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

Purpose:
!>
!> ZLATPS 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 ZTPSV 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*16 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*16 array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  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 DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, ZTPSV
!>  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 ZTPSV 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 ZTPSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 229 of file zlatps.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 DOUBLE PRECISION SCALE
240* ..
241* .. Array Arguments ..
242 DOUBLE PRECISION CNORM( * )
243 COMPLEX*16 AP( * ), X( * )
244* ..
245*
246* =====================================================================
247*
248* .. Parameters ..
249 DOUBLE PRECISION ZERO, HALF, ONE, TWO
250 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
251 $ two = 2.0d+0 )
252* ..
253* .. Local Scalars ..
254 LOGICAL NOTRAN, NOUNIT, UPPER
255 INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
256 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
257 $ XBND, XJ, XMAX
258 COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
259* ..
260* .. External Functions ..
261 LOGICAL LSAME
262 INTEGER IDAMAX, IZAMAX
263 DOUBLE PRECISION DLAMCH, DZASUM
264 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
265 EXTERNAL lsame, idamax, izamax, dlamch, dzasum, zdotc,
266 $ zdotu, zladiv
267* ..
268* .. External Subroutines ..
269 EXTERNAL dscal, xerbla, zaxpy, zdscal, ztpsv, dlabad
270* ..
271* .. Intrinsic Functions ..
272 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
273* ..
274* .. Statement Functions ..
275 DOUBLE PRECISION CABS1, CABS2
276* ..
277* .. Statement Function definitions ..
278 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
279 cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) +
280 $ abs( dimag( zdum ) / 2.d0 )
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( 'ZLATPS', -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 = dlamch( 'Safe minimum' )
317 bignum = one / smlnum
318 CALL dlabad( smlnum, bignum )
319 smlnum = smlnum / dlamch( '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 ) = dzasum( 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 ) = dzasum( 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 = idamax( 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 dscal( n, tscal, cnorm, 1 )
359 END IF
360*
361* Compute a bound on the computed solution vector to see if the
362* Level 2 BLAS routine ZTPSV 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 ztpsv( 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 zdscal( 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 120 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 110
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 zdscal( n, rec, x, 1 )
592 scale = scale*rec
593 xmax = xmax*rec
594 END IF
595 END IF
596 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
616 scale = scale*rec
617 xmax = xmax*rec
618 END IF
619 x( j ) = zladiv( 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 110 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 zdscal( 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 zdscal( 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 zaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,
664 $ 1 )
665 i = izamax( 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 zaxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1,
676 $ x( j+1 ), 1 )
677 i = j + izamax( n-j, x( j+1 ), 1 )
678 xmax = cabs1( x( i ) )
679 END IF
680 ip = ip + n - j + 1
681 END IF
682 120 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 170 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 = zladiv( uscal, tjjs )
715 END IF
716 IF( rec.LT.one ) THEN
717 CALL zdscal( 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.dcmplx( one ) ) THEN
725*
726* If the scaling needed for A in the dot product is 1,
727* call ZDOTU to perform the dot product.
728*
729 IF( upper ) THEN
730 csumj = zdotu( j-1, ap( ip-j+1 ), 1, x, 1 )
731 ELSE IF( j.LT.n ) THEN
732 csumj = zdotu( 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 130 i = 1, j - 1
740 csumj = csumj + ( ap( ip-j+i )*uscal )*x( i )
741 130 CONTINUE
742 ELSE IF( j.LT.n ) THEN
743 DO 140 i = 1, n - j
744 csumj = csumj + ( ap( ip+i )*uscal )*x( j+i )
745 140 CONTINUE
746 END IF
747 END IF
748*
749 IF( uscal.EQ.dcmplx( 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 160
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 zdscal( n, rec, x, 1 )
778 scale = scale*rec
779 xmax = xmax*rec
780 END IF
781 END IF
782 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
793 scale = scale*rec
794 xmax = xmax*rec
795 END IF
796 x( j ) = zladiv( 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 150 i = 1, n
803 x( i ) = zero
804 150 CONTINUE
805 x( j ) = one
806 scale = zero
807 xmax = zero
808 END IF
809 160 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 ) = zladiv( x( j ), tjjs ) - csumj
816 END IF
817 xmax = max( xmax, cabs1( x( j ) ) )
818 jlen = jlen + 1
819 ip = ip + jinc*jlen
820 170 CONTINUE
821*
822 ELSE
823*
824* Solve A**H * x = b
825*
826 ip = jfirst*( jfirst+1 ) / 2
827 jlen = 1
828 DO 220 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 = dconjg( 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 = zladiv( uscal, tjjs )
853 END IF
854 IF( rec.LT.one ) THEN
855 CALL zdscal( 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.dcmplx( one ) ) THEN
863*
864* If the scaling needed for A in the dot product is 1,
865* call ZDOTC to perform the dot product.
866*
867 IF( upper ) THEN
868 csumj = zdotc( j-1, ap( ip-j+1 ), 1, x, 1 )
869 ELSE IF( j.LT.n ) THEN
870 csumj = zdotc( 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 180 i = 1, j - 1
878 csumj = csumj + ( dconjg( ap( ip-j+i ) )*uscal )
879 $ *x( i )
880 180 CONTINUE
881 ELSE IF( j.LT.n ) THEN
882 DO 190 i = 1, n - j
883 csumj = csumj + ( dconjg( ap( ip+i ) )*uscal )*
884 $ x( j+i )
885 190 CONTINUE
886 END IF
887 END IF
888*
889 IF( uscal.EQ.dcmplx( 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 = dconjg( ap( ip ) )*tscal
901 ELSE
902 tjjs = tscal
903 IF( tscal.EQ.one )
904 $ GO TO 210
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 zdscal( n, rec, x, 1 )
918 scale = scale*rec
919 xmax = xmax*rec
920 END IF
921 END IF
922 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
933 scale = scale*rec
934 xmax = xmax*rec
935 END IF
936 x( j ) = zladiv( 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 200 i = 1, n
943 x( i ) = zero
944 200 CONTINUE
945 x( j ) = one
946 scale = zero
947 xmax = zero
948 END IF
949 210 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 ) = zladiv( x( j ), tjjs ) - csumj
956 END IF
957 xmax = max( xmax, cabs1( x( j ) ) )
958 jlen = jlen + 1
959 ip = ip + jinc*jlen
960 220 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 dscal( n, one / tscal, cnorm, 1 )
969 END IF
970*
971 RETURN
972*
973* End of ZLATPS
974*
ztpsv
subroutine ztpsv(uplo, trans, diag, n, ap, x, incx)
ZTPSV
Definition ztpsv.f:144

◆ zlatrd()

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

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

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

Purpose:
!>
!> ZLATRD 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', ZLATRD reduces the last NB rows and columns of a
!> matrix, of which the upper triangle is supplied;
!> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
!> matrix, of which the lower triangle is supplied.
!>
!> This is an auxiliary routine called by ZHETRD.
!>
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*16 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 DOUBLE PRECISION array, dimension (N-1)
!>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
!>          elements of the last NB columns of the reduced matrix;
!>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
!>          the first NB columns of the reduced matrix.
!>
[out]TAU
!>          TAU is COMPLEX*16 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*16 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 zlatrd.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 DOUBLE PRECISION E( * )
210 COMPLEX*16 A( LDA, * ), TAU( * ), W( LDW, * )
211* ..
212*
213* =====================================================================
214*
215* .. Parameters ..
216 COMPLEX*16 ZERO, ONE, HALF
217 parameter( zero = ( 0.0d+0, 0.0d+0 ),
218 $ one = ( 1.0d+0, 0.0d+0 ),
219 $ half = ( 0.5d+0, 0.0d+0 ) )
220* ..
221* .. Local Scalars ..
222 INTEGER I, IW
223 COMPLEX*16 ALPHA
224* ..
225* .. External Subroutines ..
226 EXTERNAL zaxpy, zgemv, zhemv, zlacgv, zlarfg, zscal
227* ..
228* .. External Functions ..
229 LOGICAL LSAME
230 COMPLEX*16 ZDOTC
231 EXTERNAL lsame, zdotc
232* ..
233* .. Intrinsic Functions ..
234 INTRINSIC dble, min
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 ) = dble( a( i, i ) )
254 CALL zlacgv( n-i, w( i, iw+1 ), ldw )
255 CALL zgemv( 'No transpose', i, n-i, -one, a( 1, i+1 ),
256 $ lda, w( i, iw+1 ), ldw, one, a( 1, i ), 1 )
257 CALL zlacgv( n-i, w( i, iw+1 ), ldw )
258 CALL zlacgv( n-i, a( i, i+1 ), lda )
259 CALL zgemv( 'No transpose', i, n-i, -one, w( 1, iw+1 ),
260 $ ldw, a( i, i+1 ), lda, one, a( 1, i ), 1 )
261 CALL zlacgv( n-i, a( i, i+1 ), lda )
262 a( i, i ) = dble( 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 zlarfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) )
271 e( i-1 ) = dble( alpha )
272 a( i-1, i ) = one
273*
274* Compute W(1:i-1,i)
275*
276 CALL zhemv( 'Upper', i-1, one, a, lda, a( 1, i ), 1,
277 $ zero, w( 1, iw ), 1 )
278 IF( i.LT.n ) THEN
279 CALL zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zscal( i-1, tau( i-1 ), w( 1, iw ), 1 )
293 alpha = -half*tau( i-1 )*zdotc( i-1, w( 1, iw ), 1,
294 $ a( 1, i ), 1 )
295 CALL zaxpy( 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 ) = dble( a( i, i ) )
308 CALL zlacgv( i-1, w( i, 1 ), ldw )
309 CALL zgemv( 'No transpose', n-i+1, i-1, -one, a( i, 1 ),
310 $ lda, w( i, 1 ), ldw, one, a( i, i ), 1 )
311 CALL zlacgv( i-1, w( i, 1 ), ldw )
312 CALL zlacgv( i-1, a( i, 1 ), lda )
313 CALL zgemv( 'No transpose', n-i+1, i-1, -one, w( i, 1 ),
314 $ ldw, a( i, 1 ), lda, one, a( i, i ), 1 )
315 CALL zlacgv( i-1, a( i, 1 ), lda )
316 a( i, i ) = dble( 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 zlarfg( n-i, alpha, a( min( i+2, n ), i ), 1,
324 $ tau( i ) )
325 e( i ) = dble( alpha )
326 a( i+1, i ) = one
327*
328* Compute W(i+1:n,i)
329*
330 CALL zhemv( 'Lower', n-i, one, a( i+1, i+1 ), lda,
331 $ a( i+1, i ), 1, zero, w( i+1, i ), 1 )
332 CALL zgemv( '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 zgemv( '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 zgemv( '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 zgemv( '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 zscal( n-i, tau( i ), w( i+1, i ), 1 )
343 alpha = -half*tau( i )*zdotc( n-i, w( i+1, i ), 1,
344 $ a( i+1, i ), 1 )
345 CALL zaxpy( 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 ZLATRD
354*

◆ zlatrs()

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

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

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

Purpose:
!>
!> ZLATRS 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
!> ZTRSV 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*16 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*16 array, dimension (N)
!>          On entry, the right hand side b of the triangular system.
!>          On exit, X is overwritten by the solution vector x.
!>
[out]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s for the triangular system
!>             A * x = s*b,  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 DOUBLE PRECISION array, dimension (N)
!>
!>          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
!>          contains the norm of the off-diagonal part of the j-th column
!>          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
!>          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
!>          must be greater than or equal to the 1-norm.
!>
!>          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
!>          returns the 1-norm of the offdiagonal part of the j-th column
!>          of A.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  A rough bound on x is computed; if that is less than overflow, ZTRSV
!>  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 ZTRSV 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 ZTRSV if 1/M(n) and 1/G(n) are both greater
!>  than max(underflow, 1/overflow).
!>

Definition at line 237 of file zlatrs.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 DOUBLE PRECISION SCALE
248* ..
249* .. Array Arguments ..
250 DOUBLE PRECISION CNORM( * )
251 COMPLEX*16 A( LDA, * ), X( * )
252* ..
253*
254* =====================================================================
255*
256* .. Parameters ..
257 DOUBLE PRECISION ZERO, HALF, ONE, TWO
258 parameter( zero = 0.0d+0, half = 0.5d+0, one = 1.0d+0,
259 $ two = 2.0d+0 )
260* ..
261* .. Local Scalars ..
262 LOGICAL NOTRAN, NOUNIT, UPPER
263 INTEGER I, IMAX, J, JFIRST, JINC, JLAST
264 DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
265 $ XBND, XJ, XMAX
266 COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM
267* ..
268* .. External Functions ..
269 LOGICAL LSAME
270 INTEGER IDAMAX, IZAMAX
271 DOUBLE PRECISION DLAMCH, DZASUM
272 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
273 EXTERNAL lsame, idamax, izamax, dlamch, dzasum, zdotc,
274 $ zdotu, zladiv
275* ..
276* .. External Subroutines ..
277 EXTERNAL dscal, xerbla, zaxpy, zdscal, ztrsv, dlabad
278* ..
279* .. Intrinsic Functions ..
280 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
281* ..
282* .. Statement Functions ..
283 DOUBLE PRECISION CABS1, CABS2
284* ..
285* .. Statement Function definitions ..
286 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
287 cabs2( zdum ) = abs( dble( zdum ) / 2.d0 ) +
288 $ abs( dimag( zdum ) / 2.d0 )
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( 'ZLATRS', -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 = dlamch( 'Safe minimum' )
327 bignum = one / smlnum
328 CALL dlabad( smlnum, bignum )
329 smlnum = smlnum / dlamch( '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 ) = dzasum( 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 ) = dzasum( 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 = idamax( 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 dscal( 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 ZTRSV 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 ztrsv( 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 zdscal( 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 120 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 110
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 zdscal( n, rec, x, 1 )
590 scale = scale*rec
591 xmax = xmax*rec
592 END IF
593 END IF
594 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
614 scale = scale*rec
615 xmax = xmax*rec
616 END IF
617 x( j ) = zladiv( 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 110 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 zdscal( 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 zdscal( 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 zaxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,
662 $ 1 )
663 i = izamax( 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 zaxpy( n-j, -x( j )*tscal, a( j+1, j ), 1,
673 $ x( j+1 ), 1 )
674 i = j + izamax( n-j, x( j+1 ), 1 )
675 xmax = cabs1( x( i ) )
676 END IF
677 END IF
678 120 CONTINUE
679*
680 ELSE IF( lsame( trans, 'T' ) ) THEN
681*
682* Solve A**T * x = b
683*
684 DO 170 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 = zladiv( uscal, tjjs )
709 END IF
710 IF( rec.LT.one ) THEN
711 CALL zdscal( 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.dcmplx( one ) ) THEN
719*
720* If the scaling needed for A in the dot product is 1,
721* call ZDOTU to perform the dot product.
722*
723 IF( upper ) THEN
724 csumj = zdotu( j-1, a( 1, j ), 1, x, 1 )
725 ELSE IF( j.LT.n ) THEN
726 csumj = zdotu( 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 130 i = 1, j - 1
734 csumj = csumj + ( a( i, j )*uscal )*x( i )
735 130 CONTINUE
736 ELSE IF( j.LT.n ) THEN
737 DO 140 i = j + 1, n
738 csumj = csumj + ( a( i, j )*uscal )*x( i )
739 140 CONTINUE
740 END IF
741 END IF
742*
743 IF( uscal.EQ.dcmplx( 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 160
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 zdscal( n, rec, x, 1 )
772 scale = scale*rec
773 xmax = xmax*rec
774 END IF
775 END IF
776 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
787 scale = scale*rec
788 xmax = xmax*rec
789 END IF
790 x( j ) = zladiv( 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 150 i = 1, n
797 x( i ) = zero
798 150 CONTINUE
799 x( j ) = one
800 scale = zero
801 xmax = zero
802 END IF
803 160 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 ) = zladiv( x( j ), tjjs ) - csumj
810 END IF
811 xmax = max( xmax, cabs1( x( j ) ) )
812 170 CONTINUE
813*
814 ELSE
815*
816* Solve A**H * x = b
817*
818 DO 220 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 = dconjg( 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 = zladiv( uscal, tjjs )
843 END IF
844 IF( rec.LT.one ) THEN
845 CALL zdscal( 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.dcmplx( one ) ) THEN
853*
854* If the scaling needed for A in the dot product is 1,
855* call ZDOTC to perform the dot product.
856*
857 IF( upper ) THEN
858 csumj = zdotc( j-1, a( 1, j ), 1, x, 1 )
859 ELSE IF( j.LT.n ) THEN
860 csumj = zdotc( 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 180 i = 1, j - 1
868 csumj = csumj + ( dconjg( a( i, j ) )*uscal )*
869 $ x( i )
870 180 CONTINUE
871 ELSE IF( j.LT.n ) THEN
872 DO 190 i = j + 1, n
873 csumj = csumj + ( dconjg( a( i, j ) )*uscal )*
874 $ x( i )
875 190 CONTINUE
876 END IF
877 END IF
878*
879 IF( uscal.EQ.dcmplx( 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 = dconjg( a( j, j ) )*tscal
888 ELSE
889 tjjs = tscal
890 IF( tscal.EQ.one )
891 $ GO TO 210
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 zdscal( n, rec, x, 1 )
908 scale = scale*rec
909 xmax = xmax*rec
910 END IF
911 END IF
912 x( j ) = zladiv( 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 zdscal( n, rec, x, 1 )
923 scale = scale*rec
924 xmax = xmax*rec
925 END IF
926 x( j ) = zladiv( 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 200 i = 1, n
933 x( i ) = zero
934 200 CONTINUE
935 x( j ) = one
936 scale = zero
937 xmax = zero
938 END IF
939 210 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 ) = zladiv( x( j ), tjjs ) - csumj
946 END IF
947 xmax = max( xmax, cabs1( x( j ) ) )
948 220 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 dscal( n, one / tscal, cnorm, 1 )
957 END IF
958*
959 RETURN
960*
961* End of ZLATRS
962*
ztrsv
subroutine ztrsv(uplo, trans, diag, n, a, lda, x, incx)
ZTRSV
Definition ztrsv.f:149

◆ zlauu2()

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

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

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

Purpose:
!>
!> ZLAUU2 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*16 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 zlauu2.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*16 A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 COMPLEX*16 ONE
119 parameter( one = ( 1.0d+0, 0.0d+0 ) )
120* ..
121* .. Local Scalars ..
122 LOGICAL UPPER
123 INTEGER I
124 DOUBLE PRECISION AII
125* ..
126* .. External Functions ..
127 LOGICAL LSAME
128 COMPLEX*16 ZDOTC
129 EXTERNAL lsame, zdotc
130* ..
131* .. External Subroutines ..
132 EXTERNAL xerbla, zdscal, zgemv, zlacgv
133* ..
134* .. Intrinsic Functions ..
135 INTRINSIC dble, dcmplx, max
136* ..
137* .. Executable Statements ..
138*
139* Test the input parameters.
140*
141 info = 0
142 upper = lsame( uplo, 'U' )
143 IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
144 info = -1
145 ELSE IF( n.LT.0 ) THEN
146 info = -2
147 ELSE IF( lda.LT.max( 1, n ) ) THEN
148 info = -4
149 END IF
150 IF( info.NE.0 ) THEN
151 CALL xerbla( 'ZLAUU2', -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 = dble( a( i, i ) )
166 IF( i.LT.n ) THEN
167 a( i, i ) = aii*aii + dble( zdotc( n-i, a( i, i+1 ), lda,
168 $ a( i, i+1 ), lda ) )
169 CALL zlacgv( n-i, a( i, i+1 ), lda )
170 CALL zgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
171 $ lda, a( i, i+1 ), lda, dcmplx( aii ),
172 $ a( 1, i ), 1 )
173 CALL zlacgv( n-i, a( i, i+1 ), lda )
174 ELSE
175 CALL zdscal( 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 = dble( a( i, i ) )
185 IF( i.LT.n ) THEN
186 a( i, i ) = aii*aii + dble( zdotc( n-i, a( i+1, i ), 1,
187 $ a( i+1, i ), 1 ) )
188 CALL zlacgv( i-1, a( i, 1 ), lda )
189 CALL zgemv( 'Conjugate transpose', n-i, i-1, one,
190 $ a( i+1, 1 ), lda, a( i+1, i ), 1,
191 $ dcmplx( aii ), a( i, 1 ), lda )
192 CALL zlacgv( i-1, a( i, 1 ), lda )
193 ELSE
194 CALL zdscal( i, aii, a( i, 1 ), lda )
195 END IF
196 20 CONTINUE
197 END IF
198*
199 RETURN
200*
201* End of ZLAUU2
202*

◆ zlauum()

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

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

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

Purpose:
!>
!> ZLAUUM 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*16 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 zlauum.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*16 A( LDA, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ONE
119 parameter( one = 1.0d+0 )
120 COMPLEX*16 CONE
121 parameter( cone = ( 1.0d+0, 0.0d+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 xerbla, zgemm, zherk, zlauu2, ztrmm
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( 'ZLAUUM', -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, 'ZLAUUM', uplo, n, -1, -1, -1 )
164*
165 IF( nb.LE.1 .OR. nb.GE.n ) THEN
166*
167* Use unblocked code
168*
169 CALL zlauu2( 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 ztrmm( 'Right', 'Upper', 'Conjugate transpose',
181 $ 'Non-unit', i-1, ib, cone, a( i, i ), lda,
182 $ a( 1, i ), lda )
183 CALL zlauu2( 'Upper', ib, a( i, i ), lda, info )
184 IF( i+ib.LE.n ) THEN
185 CALL zgemm( '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 zherk( '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 ztrmm( 'Left', 'Lower', 'Conjugate transpose',
201 $ 'Non-unit', ib, i-1, cone, a( i, i ), lda,
202 $ a( i, 1 ), lda )
203 CALL zlauu2( 'Lower', ib, a( i, i ), lda, info )
204 IF( i+ib.LE.n ) THEN
205 CALL zgemm( '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 zherk( '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 ZLAUUM
219*
zlauu2
subroutine zlauu2(uplo, n, a, lda, info)
ZLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (unblock...
Definition zlauu2.f:102
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173

◆ zrot()

subroutine zrot ( integer n,
complex*16, dimension( * ) cx,
integer incx,
complex*16, dimension( * ) cy,
integer incy,
double precision c,
complex*16 s )

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

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

Purpose:
!>
!> ZROT   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*16 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*16 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 DOUBLE PRECISION
!>
[in]S
!>          S is COMPLEX*16
!>          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 zrot.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 DOUBLE PRECISION C
111 COMPLEX*16 S
112* ..
113* .. Array Arguments ..
114 COMPLEX*16 CX( * ), CY( * )
115* ..
116*
117* =====================================================================
118*
119* .. Local Scalars ..
120 INTEGER I, IX, IY
121 COMPLEX*16 STEMP
122* ..
123* .. Intrinsic Functions ..
124 INTRINSIC dconjg
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 ) - dconjg( 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 ) - dconjg( s )*cx( i )
156 cx( i ) = stemp
157 30 CONTINUE
158 RETURN

◆ zspmv()

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

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

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

Purpose:
!>
!> ZSPMV  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*16
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]AP
!>          AP is COMPLEX*16 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*16 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*16
!>           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*16 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 zspmv.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*16 ALPHA, BETA
160* ..
161* .. Array Arguments ..
162 COMPLEX*16 AP( * ), X( * ), Y( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 COMPLEX*16 ONE
169 parameter( one = ( 1.0d+0, 0.0d+0 ) )
170 COMPLEX*16 ZERO
171 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
175 COMPLEX*16 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( 'ZSPMV ', 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 ZSPMV
336*

◆ zspr()

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

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

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

Purpose:
!>
!> ZSPR    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*16
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
[in]X
!>          X is COMPLEX*16 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*16 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 zspr.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*16 ALPHA
141* ..
142* .. Array Arguments ..
143 COMPLEX*16 AP( * ), X( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 COMPLEX*16 ZERO
150 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, INFO, IX, J, JX, K, KK, KX
154 COMPLEX*16 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( 'ZSPR ', 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 ZSPR
276*

◆ ztprfb()

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

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

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

Purpose:
!>
!> ZTPRFB 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*16 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*16 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*16 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*16 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*16 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 ztprfb.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*16 A( LDA, * ), B( LDB, * ), T( LDT, * ),
262 $ V( LDV, * ), WORK( LDWORK, * )
263* ..
264*
265* ==========================================================================
266*
267* .. Parameters ..
268 COMPLEX*16 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 zgemm, ztrmm
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 ztrmm( 'L', 'U', 'C', 'N', l, n, one, v( mp, 1 ), ldv,
352 $ work, ldwork )
353 CALL zgemm( 'C', 'N', l, n, m-l, one, v, ldv, b, ldb,
354 $ one, work, ldwork )
355 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'N', m-l, n, k, -one, v, ldv, work, ldwork,
374 $ one, b, ldb )
375 CALL zgemm( 'N', 'N', l, n, k-l, -one, v( mp, kp ), ldv,
376 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
377 CALL ztrmm( '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 ztrmm( 'R', 'U', 'N', 'N', m, l, one, v( np, 1 ), ldv,
412 $ work, ldwork )
413 CALL zgemm( 'N', 'N', m, l, n-l, one, b, ldb,
414 $ v, ldv, one, work, ldwork )
415 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'C', m, n-l, k, -one, work, ldwork,
434 $ v, ldv, one, b, ldb )
435 CALL zgemm( 'N', 'C', m, l, k-l, -one, work( 1, kp ), ldwork,
436 $ v( np, kp ), ldv, one, b( 1, np ), ldb )
437 CALL ztrmm( '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 ztrmm( 'L', 'L', 'C', 'N', l, n, one, v( 1, kp ), ldv,
474 $ work( kp, 1 ), ldwork )
475 CALL zgemm( 'C', 'N', l, n, m-l, one, v( mp, kp ), ldv,
476 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
477 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'N', m-l, n, k, -one, v( mp, 1 ), ldv,
496 $ work, ldwork, one, b( mp, 1 ), ldb )
497 CALL zgemm( 'N', 'N', l, n, k-l, -one, v, ldv,
498 $ work, ldwork, one, b, ldb )
499 CALL ztrmm( '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 ztrmm( 'R', 'L', 'N', 'N', m, l, one, v( 1, kp ), ldv,
534 $ work( 1, kp ), ldwork )
535 CALL zgemm( 'N', 'N', m, l, n-l, one, b( 1, np ), ldb,
536 $ v( np, kp ), ldv, one, work( 1, kp ), ldwork )
537 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'C', m, n-l, k, -one, work, ldwork,
556 $ v( np, 1 ), ldv, one, b( 1, np ), ldb )
557 CALL zgemm( 'N', 'C', m, l, k-l, -one, work, ldwork,
558 $ v, ldv, one, b, ldb )
559 CALL ztrmm( '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 ztrmm( 'L', 'L', 'N', 'N', l, n, one, v( 1, mp ), ldv,
594 $ work, ldb )
595 CALL zgemm( 'N', 'N', l, n, m-l, one, v, ldv,b, ldb,
596 $ one, work, ldwork )
597 CALL zgemm( '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 ztrmm( '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 zgemm( 'C', 'N', m-l, n, k, -one, v, ldv, work, ldwork,
616 $ one, b, ldb )
617 CALL zgemm( 'C', 'N', l, n, k-l, -one, v( kp, mp ), ldv,
618 $ work( kp, 1 ), ldwork, one, b( mp, 1 ), ldb )
619 CALL ztrmm( '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 ztrmm( 'R', 'L', 'C', 'N', m, l, one, v( 1, np ), ldv,
653 $ work, ldwork )
654 CALL zgemm( 'N', 'C', m, l, n-l, one, b, ldb, v, ldv,
655 $ one, work, ldwork )
656 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'N', m, n-l, k, -one, work, ldwork,
675 $ v, ldv, one, b, ldb )
676 CALL zgemm( 'N', 'N', m, l, k-l, -one, work( 1, kp ), ldwork,
677 $ v( kp, np ), ldv, one, b( 1, np ), ldb )
678 CALL ztrmm( '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 ztrmm( 'L', 'U', 'N', 'N', l, n, one, v( kp, 1 ), ldv,
713 $ work( kp, 1 ), ldwork )
714 CALL zgemm( 'N', 'N', l, n, m-l, one, v( kp, mp ), ldv,
715 $ b( mp, 1 ), ldb, one, work( kp, 1 ), ldwork )
716 CALL zgemm( '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 ztrmm( '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 zgemm( 'C', 'N', m-l, n, k, -one, v( 1, mp ), ldv,
735 $ work, ldwork, one, b( mp, 1 ), ldb )
736 CALL zgemm( 'C', 'N', l, n, k-l, -one, v, ldv,
737 $ work, ldwork, one, b, ldb )
738 CALL ztrmm( '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 ztrmm( 'R', 'U', 'C', 'N', m, l, one, v( kp, 1 ), ldv,
772 $ work( 1, kp ), ldwork )
773 CALL zgemm( 'N', 'C', m, l, n-l, one, b( 1, np ), ldb,
774 $ v( kp, np ), ldv, one, work( 1, kp ), ldwork )
775 CALL zgemm( '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 ztrmm( '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 zgemm( 'N', 'N', m, n-l, k, -one, work, ldwork,
794 $ v( 1, np ), ldv, one, b( 1, np ), ldb )
795 CALL zgemm( 'N', 'N', m, l, k-l , -one, work, ldwork,
796 $ v, ldv, one, b, ldb )
797 CALL ztrmm( '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 ZTPRFB
810*